INTEGER FUNCTION IPMPAR (I) C----------------------------------------------------------------------- C C IPMPAR PROVIDES THE INTEGER MACHINE CONSTANTS FOR THE COMPUTER C THAT IS USED. IT IS ASSUMED THAT THE ARGUMENT I IS AN INTEGER C HAVING ONE OF THE VALUES 1-10. IPMPAR(I) HAS THE VALUE ... C C INTEGERS. C C ASSUME INTEGERS ARE REPRESENTED IN THE N-DIGIT, BASE-A FORM C C SIGN ( X(N-1)*A**(N-1) + ... + X(1)*A + X(0) ) C C WHERE 0 .LE. X(I) .LT. A FOR I=0,...,N-1. C C IPMPAR(1) = A, THE BASE. C C IPMPAR(2) = N, THE NUMBER OF BASE-A DIGITS. C C IPMPAR(3) = A**N - 1, THE LARGEST MAGNITUDE. C C FLOATING-POINT NUMBERS. C C IT IS ASSUMED THAT THE SINGLE AND DOUBLE PRECISION FLOATING C POINT ARITHMETICS HAVE THE SAME BASE, SAY B, AND THAT THE C NONZERO NUMBERS ARE REPRESENTED IN THE FORM C C SIGN (B**E) * (X(1)/B + ... + X(M)/B**M) C C WHERE X(I) = 0,1,...,B-1 FOR I=1,...,M, C X(1) .GE. 1, AND EMIN .LE. E .LE. EMAX. C C IPMPAR(4) = B, THE BASE. C C SINGLE-PRECISION C C IPMPAR(5) = M, THE NUMBER OF BASE-B DIGITS. C C IPMPAR(6) = EMIN, THE SMALLEST EXPONENT E. C C IPMPAR(7) = EMAX, THE LARGEST EXPONENT E. C C DOUBLE-PRECISION C C IPMPAR(8) = M, THE NUMBER OF BASE-B DIGITS. C C IPMPAR(9) = EMIN, THE SMALLEST EXPONENT E. C C IPMPAR(10) = EMAX, THE LARGEST EXPONENT E. C C----------------------------------------------------------------------- C C TO DEFINE THIS FUNCTION FOR THE COMPUTER BEING USED, ACTIVATE C THE DATA STATMENTS FOR THE COMPUTER BY REMOVING THE C FROM C COLUMN 1. (ALL THE OTHER DATA STATEMENTS SHOULD HAVE C IN C COLUMN 1.) C C IF DATA STATEMENTS ARE NOT GIVEN FOR THE COMPUTER BEING USED, C THEN THE FORTRAN MANUAL FOR THE COMPUTER NORMALLY GIVES THE C CONSTANTS IPMPAR(1), IPMPAR(2), AND IPMPAR(3) FOR THE INTEGER C ARITHMETIC. HOWEVER, HELP MAY BE NEEDED TO OBTAIN THE CONSTANTS C IPMPAR(4),...,IPMPAR(10) FOR THE SINGLE AND DOUBLE PRECISION C ARITHMETICS. THE SUBROUTINES MACH AND RADIX ARE PROVIDED FOR C THIS PURPOSE. C C----------------------------------------------------------------------- C C IPMPAR IS AN ADAPTATION OF THE FUNCTION I1MACH, WRITTEN BY C P.A. FOX, A.D. HALL, AND N.L. SCHRYER (BELL LABORATORIES). C IPMPAR WAS FORMED BY A.H. MORRIS (NSWC). THE CONSTANTS ARE C FROM BELL LABORATORIES, NSWC, AND OTHER SOURCES. C C----------------------------------------------------------------------- INTEGER IMACH(10) C C MACHINE CONSTANTS FOR THE ALLIANT FX/8. C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 31 / C DATA IMACH( 3) / 2147483647 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 24 / C DATA IMACH( 6) / -125 / C DATA IMACH( 7) / 128 / C DATA IMACH( 8) / 53 / C DATA IMACH( 9) / -1021 / C DATA IMACH(10) / 1024 / C C MACHINE CONSTANTS FOR THE AMDAHL MACHINES. C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 31 / C DATA IMACH( 3) / 2147483647 / C DATA IMACH( 4) / 16 / C DATA IMACH( 5) / 6 / C DATA IMACH( 6) / -64 / C DATA IMACH( 7) / 63 / C DATA IMACH( 8) / 14 / C DATA IMACH( 9) / -64 / C DATA IMACH(10) / 63 / C C MACHINE CONSTANTS FOR THE AT&T 3B SERIES, AT&T C PC 7300, AND AT&T 6300. C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 31 / C DATA IMACH( 3) / 2147483647 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 24 / C DATA IMACH( 6) / -125 / C DATA IMACH( 7) / 128 / C DATA IMACH( 8) / 53 / C DATA IMACH( 9) / -1021 / C DATA IMACH(10) / 1024 / C C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM. C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 33 / C DATA IMACH( 3) / 8589934591 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 24 / C DATA IMACH( 6) / -256 / C DATA IMACH( 7) / 255 / C DATA IMACH( 8) / 60 / C DATA IMACH( 9) / -256 / C DATA IMACH(10) / 255 / C C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM. C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 39 / C DATA IMACH( 3) / 549755813887 / C DATA IMACH( 4) / 8 / C DATA IMACH( 5) / 13 / C DATA IMACH( 6) / -50 / C DATA IMACH( 7) / 76 / C DATA IMACH( 8) / 26 / C DATA IMACH( 9) / -50 / C DATA IMACH(10) / 76 / C C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS. C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 39 / C DATA IMACH( 3) / 549755813887 / C DATA IMACH( 4) / 8 / C DATA IMACH( 5) / 13 / C DATA IMACH( 6) / -50 / C DATA IMACH( 7) / 76 / C DATA IMACH( 8) / 26 / C DATA IMACH( 9) / -32754 / C DATA IMACH(10) / 32780 / C C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES C COMPUTERS, AND THE CDC CYBER 990 AND 995 (NOS C OPERATING SYSTEM). C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 48 / C DATA IMACH( 3) / 281474976710655 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 48 / C DATA IMACH( 6) / -974 / C DATA IMACH( 7) / 1070 / C DATA IMACH( 8) / 95 / C DATA IMACH( 9) / -926 / C DATA IMACH(10) / 1070 / C C MACHINE CONSTANTS FOR THE CDC CYBER 990 AND 995 C (NOS/VE OPERATING SYSTEM). C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 63 / C DATA IMACH( 3) / 9223372036854775807 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 48 / C DATA IMACH( 6) / -4096 / C DATA IMACH( 7) / 4095 / C DATA IMACH( 8) / 96 / C DATA IMACH( 9) / -4096 / C DATA IMACH(10) / 4095 / C C MACHINE CONSTANTS FOR THE CONVEX COMPUTERS C (NATIVE MODE). C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 31 / C DATA IMACH( 3) / 2147483647 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 24 / C DATA IMACH( 6) / -127 / C DATA IMACH( 7) / 127 / C DATA IMACH( 8) / 53 / C DATA IMACH( 9) / -1023 / C DATA IMACH(10) / 1023 / C C MACHINE CONSTANTS FOR THE CONVEX COMPUTERS C (IEEE MODE). C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 31 / C DATA IMACH( 3) / 2147483647 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 24 / C DATA IMACH( 6) / -125 / C DATA IMACH( 7) / 128 / C DATA IMACH( 8) / 53 / C DATA IMACH( 9) / -1021 / C DATA IMACH(10) / 1024 / C C MACHINE CONSTANTS FOR THE CRAY 2, X-MP, AND Y-MP C (CFT77 COMPILER USING THE 64 BIT INTEGER ARITHMETIC). C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 63 / C DATA IMACH( 3) / 9223372036854775807 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 48 / C DATA IMACH( 6) / -8188 / C DATA IMACH( 7) / 8189 / C DATA IMACH( 8) / 96 / C DATA IMACH( 9) / -8188 / C DATA IMACH(10) / 8189 / C C MACHINE CONSTANTS FOR THE CRAY 2, X-MP, AND Y-MP C (CFT77 COMPILER USING THE 46 BIT INTEGER ARITHMETIC). C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 46 / C DATA IMACH( 3) / 70368744177663 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 48 / C DATA IMACH( 6) / -8188 / C DATA IMACH( 7) / 8189 / C DATA IMACH( 8) / 96 / C DATA IMACH( 9) / -8188 / C DATA IMACH(10) / 8189 / C C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200. C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 15 / C DATA IMACH( 3) / 32767 / C DATA IMACH( 4) / 16 / C DATA IMACH( 5) / 6 / C DATA IMACH( 6) / -64 / C DATA IMACH( 7) / 63 / C DATA IMACH( 8) / 14 / C DATA IMACH( 9) / -64 / C DATA IMACH(10) / 63 / C C MACHINE CONSTANTS FOR THE HARRIS 220. C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 23 / C DATA IMACH( 3) / 8388607 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 23 / C DATA IMACH( 6) / -127 / C DATA IMACH( 7) / 127 / C DATA IMACH( 8) / 38 / C DATA IMACH( 9) / -127 / C DATA IMACH(10) / 127 / C C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 C AND DPS 8/70 SERIES. C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 35 / C DATA IMACH( 3) / 34359738367 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 27 / C DATA IMACH( 6) / -127 / C DATA IMACH( 7) / 127 / C DATA IMACH( 8) / 63 / C DATA IMACH( 9) / -127 / C DATA IMACH(10) / 127 / C C MACHINE CONSTANTS FOR THE HP 9000. C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 31 / C DATA IMACH( 3) / 2147483647 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 24 / C DATA IMACH( 6) / -126 / C DATA IMACH( 7) / 128 / C DATA IMACH( 8) / 53 / C DATA IMACH( 9) / -1021 / C DATA IMACH(10) / 1024 / C C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, C THE IBM 3033, THE ICL 2900, THE ITEL AS/6, THE C XEROX SIGMA 5/7/9, AND THE SEL SYSTEMS 85/86. C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 31 / C DATA IMACH( 3) / 2147483647 / C DATA IMACH( 4) / 16 / C DATA IMACH( 5) / 6 / C DATA IMACH( 6) / -64 / C DATA IMACH( 7) / 63 / C DATA IMACH( 8) / 14 / C DATA IMACH( 9) / -64 / C DATA IMACH(10) / 63 / C C MACHINE CONSTANTS FOR THE IBM PC. C DATA IMACH( 1) / 2 / DATA IMACH( 2) / 31 / DATA IMACH( 3) / 2147483647 / DATA IMACH( 4) / 2 / DATA IMACH( 5) / 24 / DATA IMACH( 6) / -125 / DATA IMACH( 7) / 128 / DATA IMACH( 8) / 53 / DATA IMACH( 9) / -1021 / DATA IMACH(10) / 1024 / C C MACHINE CONSTANTS FOR THE MACINTOSH II - ABSOFT C MACFORTRAN II. C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 31 / C DATA IMACH( 3) / 2147483647 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 24 / C DATA IMACH( 6) / -125 / C DATA IMACH( 7) / 128 / C DATA IMACH( 8) / 53 / C DATA IMACH( 9) / -1021 / C DATA IMACH(10) / 1024 / C C MACHINE CONSTANTS FOR THE PDP-11 FORTRAN SUPPORTING C 32-BIT INTEGER ARITHMETIC. C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 31 / C DATA IMACH( 3) / 2147483647 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 24 / C DATA IMACH( 6) / -127 / C DATA IMACH( 7) / 127 / C DATA IMACH( 8) / 56 / C DATA IMACH( 9) / -127 / C DATA IMACH(10) / 127 / C C MACHINE CONSTANTS FOR THE SEQUENT BALANCE 8000. C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 31 / C DATA IMACH( 3) / 2147483647 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 24 / C DATA IMACH( 6) / -125 / C DATA IMACH( 7) / 128 / C DATA IMACH( 8) / 53 / C DATA IMACH( 9) / -1021 / C DATA IMACH(10) / 1024 / C C MACHINE CONSTANTS FOR THE SILICON GRAPHICS IRIS-4D C SERIES (MIPS R3000 PROCESSOR). C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 31 / C DATA IMACH( 3) / 2147483647 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 24 / C DATA IMACH( 6) / -125 / C DATA IMACH( 7) / 128 / C DATA IMACH( 8) / 53 / C DATA IMACH( 9) / -1021 / C DATA IMACH(10) / 1024 / C C MACHINE CONSTANTS FOR THE SUN 3. C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 31 / C DATA IMACH( 3) / 2147483647 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 24 / C DATA IMACH( 6) / -125 / C DATA IMACH( 7) / 128 / C DATA IMACH( 8) / 53 / C DATA IMACH( 9) / -1021 / C DATA IMACH(10) / 1024 / C C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 35 / C DATA IMACH( 3) / 34359738367 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 27 / C DATA IMACH( 6) / -128 / C DATA IMACH( 7) / 127 / C DATA IMACH( 8) / 60 / C DATA IMACH( 9) / -1024 / C DATA IMACH(10) / 1023 / C C MACHINE CONSTANTS FOR THE VAX AND MICROVAX C COMPUTERS - F AND D FLOATING ARITHMETICS. C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 31 / C DATA IMACH( 3) / 2147483647 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 24 / C DATA IMACH( 6) / -127 / C DATA IMACH( 7) / 127 / C DATA IMACH( 8) / 56 / C DATA IMACH( 9) / -127 / C DATA IMACH(10) / 127 / C C MACHINE CONSTANTS FOR THE VAX AND MICROVAX C COMPUTERS - F AND G FLOATING ARITHMETICS. C C DATA IMACH( 1) / 2 / C DATA IMACH( 2) / 31 / C DATA IMACH( 3) / 2147483647 / C DATA IMACH( 4) / 2 / C DATA IMACH( 5) / 24 / C DATA IMACH( 6) / -127 / C DATA IMACH( 7) / 127 / C DATA IMACH( 8) / 53 / C DATA IMACH( 9) / -1023 / C DATA IMACH(10) / 1023 / C IPMPAR = IMACH(I) RETURN END C----------------------------------------------------------------------- SUBROUTINE MACH (MO, N, IBETA, IMAX, IDMAX, IMACH, RMACH, DMACH) C----------------------------------------------------------------------- REAL RMACH(3) DOUBLE PRECISION DMACH(3) INTEGER IMACH(10) C----------------------------------------------------------------------- C C COMPUTATION OF THE ENVIRONMENTAL CONSTANTS FOR THE C SINGLE AND DOUBLE PRECISION FLOATING POINT ARITHMETICS C C ----------- C C IT IS ASSUMED THAT THE SINGLE AND DOUBLE PRECISION FLOATING C POINT ARITHMETICS HAVE THE SAME BASE, SAY IBETA, AND THAT C THE NONZERO NUMBERS ARE REPRESENTED IN THE FORM C C SIGN (IBETA**K) * (X(1)/IBETA + ... + X(M)/IBETA ** M) C C WHERE EACH X(I) IS AN INTEGER SUCH THAT C C 0 .LE. X(I) .LT. IBETA C C AND X(1) .GE. 1 . THE EXPONENT K IS AN INTEGER SUCH THAT C C MINEXP .LE. K .LE. MAXEXP. C C THE VALUES M, MINEXP, AND MAXEXP ARE NEEDED FOR BOTH THE C SINGLE AND DOUBLE PRECISION ARITHMETICS IN ORDER TO DEFINE C THE FUNCTION IPMPAR. THIS SUBROUTINE ATTEMPTS TO HELP THE C USER IN OBTAINING THIS INFORMATION. C C----------------------------------------------------------------------- C INPUT AND OUTPUT C----------------------------------------------------------------------- C C INPUT ... C C MO - MODE OF OPERATION OF THE ROUTINE. C C MO = 0 OUTPUT UNIT N IS NOT USED. THE SINGLE C AND DOUBLE PRECISION ARITHMETICS ARE C EXAMINED. C MO = 1 IT IS ASSUMED THAT UNIT N IS USED. C MACH SEARCHES FOR THE MAXIMUM EXPONENT C MAXEXP FOR THE SINGLE PRECISION ARITH- C METIC. THE DOUBLE PRECISION ARITHMETIC C IS NOT EXAMINED. C MO = 2 IT IS ASSUMED THAT UNIT N IS USED. C MACH SEARCHES FOR THE MAXIMUM EXPONENT C MAXEXP FOR THE DOUBLE PRECISION ARITH- C METIC. THE SINGLE PRECISION ARITHMETIC C IS NOT EXAMINED. C C N - IF N IS POSITIVE THEN N IS THE NUMBER OF AN C OUTPUT UNIT, WHERE ANY INFORMATION WRITTEN ON C THE UNIT WILL BE AVAILABLE TO THE USER IF MACH C TERMINATES BECAUSE OF OVERFLOW. IF N .LE. 0 C THEN NO SUCH OUTPUT UNIT IS TO BE USED. (IF NO C SUCH OUTPUT UNIT IS USED THEN SET MO = 0.) C C IBETA - THE BASE OF THE FLOATING POINT ARITHMETICS. (IT C IS ASSUMED THAT THE SINGLE AND DOUBLE PRECISION C ARITHMETICS HAVE THE SAME BASE.) IF THIS VALUE C IS NOT KNOWN THEN C C CALL RADIX (IBETA) C C WILL (HOPEFULLY) PROVIDE THE CORRECT VALUE. AS C FAR AS IS KNOWN, THE SUBROUTINE RADIX OPERATES C PROPERLY ON ALL COMPUTERS. NEVERTHELESS, THE C VALUE OBTAINED FOR IBETA SHOULD BE CHECKED. C C IMAX - IF IMAX IS POSITIVE THEN IMAX IS ASSUMED TO BE C AN APPROXIMATION OF THE MAXIMUM EXPONENT MAXEXP C FOR THE SINGLE PRECISION NUMBERS. OTHERWISE, IF C IMAX .LE. 0, THEN THE ROUTINE DEFINES ITS OWN C INITIAL APPROXIMATION FOR MAXEXP. C C IDMAX - IF IDMAX IS POSITIVE THEN IDMAX IS ASSUMED TO BE C AN APPROXIMATION OF THE MAXIMUM EXPONENT MAXEXP C FOR THE DOUBLE PRECISION NUMBERS. OTHERWISE, IF C IDMAX .LE. 0, THEN THE ROUTINE DEFINES ITS OWN C INITIAL APPROXIMATION FOR MAXEXP. C C C OUTPUT (WHEN MO = 0) ... C C IMACH - INTEGER ARRAY OF DIMENSION 10 APPEARING IN THE C DEFINITION OF THE FUNCTION IPMPAR. C IPMPAR(I) = IMACH(I) I = 4,...,10 C C RMACH - REAL ARRAY OF DIMENSION 3 GIVING THE FOLLOWING C CONSTANTS FOR THE SINGLE PRECISION ARITHMETIC. C RMACH(1) = B**(1-M), THE MACHINE PRECISION C RMACH(2) = THE SMALLEST POSITIVE NUMBER C RMACH(3) = THE LARGEST POSITIVE NUMBER C C DMACH - DOUBLE PRECISION ARRAY OF DIMENSION 3 GIVING THE C FOLLOWING CONSTANTS FOR THE DOUBLE PRECISION C ARITHMETIC. C DMACH(1) = B**(1-M), THE MACHINE PRECISION C DMACH(2) = THE SMALLEST POSITIVE NUMBER C DMACH(3) = THE LARGEST POSITIVE NUMBER C C----------------------------------------------------------------------- C USAGE C----------------------------------------------------------------------- C C THE FOLLOWING PROCEDURE IS RECOMMENDED FOR OBTAINING THE C DATA NEEDED FOR DEFINING IPMPAR. C C C STEP (1). IN THIS STEP WE SEARCH FOR THE MAXIMUM EXPONENT C MAXEXP FOR THE SINGLE PRECISION ARITHMETIC. THE DOUBLE C PRECISION ARITHMETIC IS NOT CONSIDERED. IT IS ASSUMED THAT C AN OUTPUT UNIT N IS BEING USED. GIVEN N AND IBETA. SET C IMAX = 0 AND COMPUTE ... C C CALL MACH (1, N, IBETA, IMAX, IDMAX, IMACH, RMACH, DMACH) C C WHEN THIS CODE IS RUN, INFORMATION IS GIVEN ON UNIT N FOR C RESETTING IMAX. IF THE MAXIMUM EXPONENT HAS BEEN FOUND C (IN THIS CASE, THE LAST INTEGER WRITTEN ON UNIT N WILL NOT C BE FOLLOWED BY ANY STATEMENT EXCEPT POSSIBLY AN OVERFLOW C STATEMENT), THEN SET IMAX TO THE LAST INTEGER WRITTEN ON C UNIT N AND GO TO STEP (2). OTHERWISE, IF THE MAXIMUM C EXPONENT HAS NOT BEEN FOUND, THEN RESET IMAX ACCORDING TO C THE INSTRUCTIONS GIVEN ON UNIT N AND RERUN THE CODE. THE C CODE MAY BE RERUN WITH DIFFERENT VALUES OF IMAX UNTIL THE C THE MAXIMUM EXPONENT HAS BEEN FOUND OR A SATISFACTORY C APPROXIMATION FOR THE MAXIMUM EXPONENT HAS BEEN OBTAINED. C THEN SET IMAX TO THE MAXIMUM EXPONENT (OR THE APPROXIMATION) C AND GO TO STEP (2). C C C STEP (2). IN THIS STEP WE SEARCH FOR THE MAXIMUM EXPONENT C MAXEXP FOR THE DOUBLE PRECISION ARITHMETIC. THE SINGLE C PRECISION ARITHMETIC IS NOT CONSIDERED. IT IS ASSUMED THAT C AN OUTPUT UNIT N IS BEING USED. GIVEN N AND IBETA. SET C IDMAX = 0 AND COMPUTE ... C C CALL MACH (2, N, IBETA, IMAX, IDMAX, IMACH, RMACH, DMACH) C C THE PROCEDURE USED IN THIS STEP FOR FINDING THE MAXIMUM C EXPONENT OR OBTAINING A SUITABLE APPROXIMATION FOR THE C MAXIMUM EXPONENT IS THE SAME AS IN STEP (1), THE ONLY C DIFFERENCE BEING THAT NOW ONE WORKS WITH IDMAX INSTEAD C OF IMAX. WHEN THE MAXIMUM EXPONENT IS FOUND OR A SUITABLE C APPROXIMATION IS OBTAINED, THEN RESET IDMAX TO THE MAXIMUM C EXPONENT (OR THE APPROXIMATION) AND GO TO STEP (3). C C C STEP (3). GIVEN THE VALUES OBTAINED FOR IBETA, IMAX, AND C IDMAX. THEN COMPUTE ... C C CALL MACH (0, 0, IBETA, IMAX, IDMAX, IMACH, RMACH, DMACH) C C WHEN THIS CODE TERMINATES, ALL THE DATA NEEDED FOR DEFINING C IPMPAR(4),...,IPMPAR(10) IS GIVEN IN THE ARRAY IMACH. THE C DATA GIVEN IN THE ARRAYS RMACH AND DMACH ARE PROVIDED SO THAT C THE USER CAN CHECK THE INFORMATION IN IMACH. C C RMACH(1) DEPENDS ON IMACH(4) AND IMACH(5) C RMACH(2) DEPENDS ON IMACH(4) AND IMACH(6) C RMACH(3) DEPENDS ON IMACH(4) AND IMACH(7) C DMACH(1) DEPENDS ON IMACH(4) AND IMACH(8) C DMACH(2) DEPENDS ON IMACH(4) AND IMACH(9) C DMACH(3) DEPENDS ON IMACH(4) AND IMACH(10) C C THE VALUES IN RMACH AND DMACH SHOULD BE CHECKED TO SEE IF C THEY MAKE SENSE. (FOR EXAMPLE, RMACH(2) AND DMACH(2) SHOULD C NEVER BE 0.) C C----------------------------------------------------------------------- C GENERAL INFORMATION C----------------------------------------------------------------------- C C THE VALUES IN IMACH(6) AND IMACH(9) ARE THE MINIMUM EXPONENTS C FOR THE NUMBERS IN THE SINGLE AND DOUBLE PRECISION ARITHMETICS C WHICH HAVE FULL ACCURACY. ON SOME COMPUTERS, ACCURACY IS LOST C IN THE STORAGE OF SOME SMALL NUMBERS. THIS OCCURS IN THE DOUBLE C PRECISION ARITHMETICS OF THE CDC 6000-7000 SERIES COMPUTES. ON C THESE MACHINES, THE DOUBLE PRECISION NUMBERS LESS THAT 2**(-927) C NORMALLY HAVE ONLY SINGLE PRECISION ACCURACY. CONSEQUENTLY, C IMACH(9) WILL HAVE THE COMPUTED VALUE -926 INSTEAD OF -974 C (WHICH ONE WOULD NORMALLY EXPECT). IN THIS CASE, -926 IS THE C VALUE THAT IS CONSIDERED TO BE CORRECT. C C THIS PACKAGE OF SUBROUTINES INCLUDES MACH, RADIX, MACH1, STORE2, C MACH2, DSTOR2. THE PACKAGE IS EXPERIMENTAL. IT IS PROVIDED AS C AN AID IN DEFINING THE FUNCTION IPMPAR. THE SUBROUTINES IN THE C PACKAGE ARE NOT USED BY ANY OF THE FUNCTIONS OR SUBROUTINES IN C THE NSWC LIBRARY. C C THE PURPOSE OF THE SUBROUTINES STORE2 AND DSTOR2 IS TO FORCE C DATA TO BE STORED IN MEMORY. THESE ROUTINES ARE NEEDED WHEN C DATA ARE STORED IN OVERSIZED REGISTERS. C C THE ALGORITHM FOR THE SUBROUTINE RADIX WAS DEVELOPED BY M.A. C MALCOLM (STANFORD UNIVERSITY). SEE REFERENCES (1) AND (2). C C----------------- C C WRITTEN BY C ALFRED H. MORRIS, JR. C NAVAL SURFACE WARFARE CENTER C DAHLGREN VIRGINIA C C----------------- C C REVISED ... MARCH 1992 C C----------------- C C REFERENCES ... C C (1) MALCOLM, M.A., ALGORITHMS TO REVEAL PROPERTIES OF FLOATING C POINT ARITHMETIC, COMM. ACM (15), 1972, PP. 949-951. C C (2) GENTLEMEN, W.M. AND MAROVICH, S.B., MORE ON ALGORITHMS THAT C REVEAL PROPERTIES OF FLOATING POINT ARITHMETIC UNITS, C COMM. ACM (17), 1974, PP. 276-277. C C (3) CODY, W.J. AND WAITE, W., SOFTWARE MANUAL FOR THE ELEMENTARY C FUNCTIONS, PRENTICE-HALL, 1980, PP. 258-264. C C (4) CODY, W.J., ALGORITHM 665. MACHAR, A SUBROUTINE TO DYNAMICALLY C DETERMINE MACHINE PARAMETERS, ACM TRANS. MATH SOFTWARE (14), C 1988, PP. 303-311. C C----------------------------------------------------------------------- DOUBLE PRECISION DEPS, DINT, DMIN, DMAX C----------------- IMACH(1) = 0 IMACH(2) = 0 IMACH(3) = 0 C N0 = N IF (MO .LE. 0) N0 = 0 IF (MO .GE. 2) GO TO 10 C----------------------------------------------------------------------- C OBTAIN THE SINGLE PRECISION INFORMATION C----------------------------------------------------------------------- MAXEXP = IMAX CALL MACH1 (N0, IBETA, M, MINEXP, MAXEXP, EPS, XINT, XMIN, XMAX) IF (MO .EQ. 1) STOP RMACH(1) = EPS RMACH(2) = XMIN RMACH(3) = XMAX IMACH(4) = IBETA IMACH(5) = M IMACH(6) = MINEXP IMACH(7) = MAXEXP C----------------------------------------------------------------------- C OBTAIN THE DOUBLE PRECISION INFORMATION C----------------------------------------------------------------------- 10 MAXEXP = IDMAX CALL MACH2 (N0, IBETA, M, MINEXP, MAXEXP, DEPS, DINT, DMIN, DMAX) IF (MO .GE. 2) STOP DMACH(1) = DEPS DMACH(2) = DMIN DMACH(3) = DMAX IMACH(8) = M IMACH(9) = MINEXP IMACH(10)= MAXEXP RETURN END SUBROUTINE RADIX (IBETA) C----------------------------------------------------------------------- C SET IBETA = THE RADIX OF THE FLOATING POINT ARITHMETIC C----------------------------------------------------------------------- COMMON /SPDATA/ D1, D2 C ONE = FLOAT(1) C A = ONE 10 A = A + A CALL STORE2 (A + ONE, A) Y = D1 - D2 IF (Y .EQ. ONE) GO TO 10 C B = ONE 20 B = B + B CALL STORE2 (A + B, A) IF (D1 .EQ. D2) GO TO 20 C IBETA = INT(D1 - D2) RETURN END SUBROUTINE MACH1 (N, IBETA, M, MINEXP, MAXEXP, EPS, XINT, * XMIN, XMAX) REAL EPS, XINT, XMIN, XMAX C----------------------------------------------------------------------- C C COMPUTATION OF THE ENVIRONMENTAL CONSTANTS C FOR THE SINGLE PRECISION FLOATING POINT ARITHMETIC C C ----------- C C INPUT ... C C N - IF N IS POSITIVE THEN N IS THE NUMBER OF AN C OUTPUT UNIT. IN THIS CASE IT IS ASSUMED THAT C ANY INFORMATION THAT IS WRITTEN ON THE UNIT C WILL BE AVAILABLE TO THE USER IF THE ROUTINE C TERMINATES BECAUSE OF OVERFLOW. UNIT N IS C USED ONLY FOR COMPUTING THE EXACT MAXIMUM C BASE IBETA EXPONENT FOR THE FLOATING POINT C NUMBERS (THIS EXPONENT IS STORED IN MAXEXP). C IF THE EXACT MAXIMUM EXPONENT IS NOT NEEDED C (OR HAS ALREADY BEEN OBTAINED) THEN SET N C TO 0 OR A NEGATIVE VALUE. C C IBETA - THE BASE OF THE FLOATING POINT ARITHMETIC. C C MAXEXP - IF MAXEXP IS POSITIVE THEN MAXEXP IS ASSUMED TO C BE AN APPROXIMATION OF THE MAXIMUM (BASE IBETA) C EXPONENT FOR THE FLOATING POINT NUMBERS. OTHER- C WISE, IF MAXEXP .LE. 0, THEN AN APPROXIMATION C FOR THE MAXIMUM EXPONENT IS OBTAINED. C C OUTPUT ... C C M - THE NUMBER OF BASE IBETA DIGITS IN THE FLOATING C POINT REPRESENTATION. C C MINEXP - THE LARGEST IN MAGNITUDE NEGATIVE INTEGER SUCH C THAT FLOAT(IBETA)**(MINEXP - 1) IS A POSITIVE C NUMBER. C C MAXEXP - IF MAXEXP IS POSITIVE ON INPUT AND N .LE. 0 C THEN MAXEXP IS NOT MODIFIED. C C IF MAXEXP .LE. 0 ON INPUT AND N .LE. 0 THEN C ON OUTPUT MAXEXP = AN APPROXIMATION OF THE C MAXIMUM (BASE IBETA) EXPONENT FOR THE FLOATING C POINT NUMBERS. C C IF N IS POSITIVE THEN THE ROUTINE SEARCHES FOR C THE EXACT MAXIMUM EXPONENT FOR THE FLOATING C POINT NUMBERS. IF MAXEXP IS POSITIVE ON INPUT C THEN THE SEARCH BEGINS WITH MAXEXP. IF C MAXEXP .LE. 0 ON INPUT THEN THE ROUTINE BEGINS C THE SEARCH WITH ITS OWN INITIAL APPROXIMATION C FOR MAXEXP. THE FOLLOWING LOOP IS PERFORMED. C (1) CHECK THE CURRENT VALUE OF MAXEXP C FOR OVERFLOW. IF OVERFLOW OCCURS C THEN THE ROUTINE WILL (HOPEFULLY) C ABORT. OTHERWISE, IF OVERFLOW DOES C NOT OCCUR THEN GO TO (2). C (2) WRITE ON UNIT N THE CURRENT VALUE C OF MAXEXP AND GO TO (3). C (3) INCREASE THE VALUE OF MAXEXP BY 1 C AND RETURN TO (1). C IF THE OVERFLOW TEST IN (1) FAILS THEN THE C ROUTINE ABORTS AFTER 500 PASSES THROUGH THE C LOOP. IF THE OVERFLOW TEST WORKS PROPERLY C THEN THE LAST INTEGER WRITTEN ON UNIT N IS C THE DESIRED MAXIMUM EXPONENT FOR THE FLOAT- C ING POINT NUMBERS. RESET MAXEXP TO THIS C INTEGER, SET N = 0, AND RERUN THE ROUTINE. C C EPS - THE RELATIVE PRECISION OF THE FLOATING ARITHMETIC. C EPS = FLOAT(IBETA)**(1 - M) C C XINT - THE LARGEST POSITIVE INTEGER THAT CAN C BE EXACTLY REPRESENTED AS A FLOATING C POINT NUMBER. XINT = B**M - 1 WHERE C B = FLOAT(IBETA). C C XMIN - THE SMALLEST NONZERO POWER OF THE BASE. C XMIN = FLOAT(IBETA)**(MINEXP - 1) C C XMAX - THE LARGEST FOATING POINT NUMBER THAT CAN C BE OBTAINED HAVING THE EXPONENT MAXEXP. C XMAX = (1 - B**(-M)) * B**MAXEXP WHERE C B = FLOAT(IBETA). IF MAXEXP IS THE MAXIMUM C EXPONENT FOR THE FLOATING POINT NUMBERS C THEN XMAX IS THE LARGEST FLOATING POINT C NUMBER THAT EXISTS. THE VALUE OBTAINED C FOR XMAX MAY BE AFFECTED SLIGHTLY BY C ROUNDOFF ERROR. C C----------------------------------------------------------------------- REAL B, B2, BINV, BM1, D1, D2, ONE, P, Q, T, X, Z, ZERO C---------------- COMMON /SPDATA/ D1, D2 C ZERO = FLOAT(0) ONE = FLOAT(1) B = FLOAT(IBETA) B2 = B*B BM1 = FLOAT(IBETA - 1) BINV = ONE/B C----------------------------------------------------------------------- C COMPUTE M AND EPS C----------------------------------------------------------------------- M = 1 T = B 10 M = M + 1 Z = T T = B*T CALL STORE2 (T + ONE, T) X = D1*BINV - Z IF (X .EQ. BINV) GO TO 10 C XINT = (Z - ONE)*B + BM1 XMAX = XINT/T IF (XMAX .LT. ONE) GO TO 20 M = M - 1 T = Z Z = Z*BINV XINT = (Z - ONE)*B + BM1 XMAX = XINT/T 20 EPS = ONE/Z C----------------------------------------------------------------------- C COMPUTE MINEXP AND XMIN C----------------------------------------------------------------------- P = ONE + EPS Q = ONE + EPS*B2 C C MINEXP MUST BE FOUND. THIS LOOP OBTAINS THE LARGEST C K = 2**I SUCH THAT B**(-K) DOES NOT UNDERFLOW. C K = 1 Z = BINV 30 X = Z Z = (X*X)*ONE CALL STORE2 (Z*XINT, Z*T) IF (D1 .EQ. D2) GO TO 40 IF (Z + Z .EQ. ZERO .OR. ABS(Z) .GE. X) GO TO 40 CALL STORE2 (Z, P*Z) IF (T*D2 .EQ. T*Z) GO TO 40 K = K + K GO TO 30 C 40 KM = K + K J = 0 C C LOOP TO DETERMINE MINEXP AND XMIN. C 50 XMIN = X X = (X*BINV)*ONE CALL STORE2 (X*XINT, X*T) IF (D1 .EQ. D2) GO TO 90 IF (X + X .EQ. ZERO .OR. ABS(X) .GE. XMIN) GO TO 90 CALL STORE2 (X, P*X) IF (T*D2 .EQ. T*X) GO TO 80 K = K + 1 GO TO 50 C C IF THERE IS LOSS OF ACCURACY NOT DUE TO UNDERFLOW C THEN SET J = NUMBER OF DIGITS POSSIBLY LOST DUE TO C THIS LOSS OF ACCURACY. C 80 CALL STORE2 (X, Q*X) IF (T*D2 .NE. T*X) GO TO 90 81 Z = X J = J + 1 X = (X*BINV)*ONE CALL STORE2 (X*XINT, X*T) IF (D1 .EQ. D2) GO TO 90 IF (X + X .NE. ZERO .AND. ABS(X) .LT. Z) GO TO 81 C 90 MINEXP = 1 - K C----------------------------------------------------------------------- C DEFINE AN INITIAL APPROXIMATION FOR MAXEXP AND XMAX C WHEN MAXEXP .LE. 0 ON INPUT C----------------------------------------------------------------------- IF (MAXEXP .GT. 0) GO TO 101 IF (IBETA .EQ. 2 .OR. IBETA .EQ. 8 .OR. * IBETA .EQ. 16) GO TO 100 C MAXEXP = K - 3 IF (N .GT. 0) WRITE (N,200) MAXEXP T = ONE/(B2*B2*XMIN) XMAX = (XMAX*T)*B GO TO 110 C 100 K = K + J IF (K + K .GT. KM + 2) KM = KM + KM MAXEXP = KM - K - 3 101 IF (N .GT. 0) WRITE (N,200) MAXEXP T = B**(MAXEXP - 2) XMAX = ((XMAX*T)*B)*B C----------------------------------------------------------------------- C CHECK THE APPROXIMATION FOR MAXEXP C----------------------------------------------------------------------- 110 CALL STORE2 (T, T*P) IF (D1 .EQ. D2) GO TO 150 IF (N .LE. 0) RETURN C----------------------------------------------------------------------- C LOOP TO FIND THE EXACT LARGEST VALUE FOR MAXEXP C----------------------------------------------------------------------- WRITE (N,210) MAXEXP DO 120 L = 1,500 T = T*B XMAX = XMAX*B MAXEXP = MAXEXP + 1 CALL STORE2 (T, T*P) IF (D1 .EQ. D2) GO TO 150 WRITE (N,220) MAXEXP 120 CONTINUE WRITE (N,240) STOP C----------------------------------------------------------------------- C REPORTING OVERFLOW ON UNIT N C----------------------------------------------------------------------- 150 IF (N .GT. 0) WRITE (N,230) STOP C----------------------------------------------------------------------- C FORMAT STATEMENTS C----------------------------------------------------------------------- 200 FORMAT (50H THE INITIAL APPROXIMATION FOR IMAX (OR MAXEXP) IS// * I25// * 47H IF NO FURTHER INFORMATION APPEARS ON THIS FILE/ * 50H THEN SET IMAX (OR MAXEXP) TO A SMALLER VALUE THAN/ * 39H THIS APPROXIMATION AND RERUN THE CODE.//) 210 FORMAT (51H THE LOOP TO FIND THE LARGEST POSSIBLE EXPONENT HAS/ * 48H BEGUN. SET IMAX (OR MAXEXP) TO THE LAST INTEGER/ * 14H THAT FOLLOWS.//I25) 220 FORMAT (I25) 230 FORMAT(/32H ****** OVERFLOW OCCURS ******) 240 FORMAT(/46H ****** 500 PASSES WERE MADE THROUGH THE LOOP./ * 45H THE MAXIMUM EXPONENT CANNOT BE FOUND./ * 43H IF ONE WISHES, SET IMAX (OR MAXEXP)/ * 45H TO A LARGER VALUE AND RERUN THE CODE./) C----------------------------------------------------------------------- END SUBROUTINE STORE2 (A, B) C----------------------------------------------------------------------- C STORAGE OF SINGLE PRECISION INFORMATION INTO MEMORY C----------------------------------------------------------------------- COMMON /SPDATA/ D1, D2 D1 = A D2 = B RETURN END SUBROUTINE MACH2 (N, IBETA, M, MINEXP, MAXEXP, EPS, XINT, * XMIN, XMAX) DOUBLE PRECISION EPS, XINT, XMIN, XMAX C----------------------------------------------------------------------- C C COMPUTATION OF THE ENVIRONMENTAL CONSTANTS C FOR THE DOUBLE PRECISION FLOATING POINT ARITHMETIC C C ----------- C C INPUT ... C C N - IF N IS POSITIVE THEN N IS THE NUMBER OF AN C OUTPUT UNIT. IN THIS CASE IT IS ASSUMED THAT C ANY INFORMATION THAT IS WRITTEN ON THE UNIT C WILL BE AVAILABLE TO THE USER IF THE ROUTINE C TERMINATES BECAUSE OF OVERFLOW. UNIT N IS C USED ONLY FOR COMPUTING THE EXACT MAXIMUM C BASE IBETA EXPONENT FOR THE FLOATING POINT C NUMBERS (THIS EXPONENT IS STORED IN MAXEXP). C IF THE EXACT MAXIMUM EXPONENT IS NOT NEEDED C (OR HAS ALREADY BEEN OBTAINED) THEN SET N C TO 0 OR A NEGATIVE VALUE. C C IBETA - THE BASE OF THE FLOATING POINT ARITHMETIC. C C MAXEXP - IF MAXEXP IS POSITIVE THEN MAXEXP IS ASSUMED TO C BE AN APPROXIMATION OF THE MAXIMUM (BASE IBETA) C EXPONENT FOR THE FLOATING POINT NUMBERS. OTHER- C WISE, IF MAXEXP .LE. 0, THEN AN APPROXIMATION C FOR THE MAXIMUM EXPONENT IS OBTAINED. C C OUTPUT ... C C M - THE NUMBER OF BASE IBETA DIGITS IN THE FLOATING C POINT REPRESENTATION. C C MINEXP - LET B = DBLE(FLOAT(IBETA)). THEN MINEXP IS THE C LARGEST IN MAGNITUDE NEGATIVE INTEGER SUCH THAT C B**(MINEXP - 1) IS A POSITIVE NUMBER. C C MAXEXP - IF MAXEXP IS POSITIVE ON INPUT AND N .LE. 0 C THEN MAXEXP IS NOT MODIFIED. C C IF MAXEXP .LE. 0 ON INPUT AND N .LE. 0 THEN C ON OUTPUT MAXEXP = AN APPROXIMATION OF THE C MAXIMUM (BASE IBETA) EXPONENT FOR THE FLOATING C POINT NUMBERS. C C IF N IS POSITIVE THEN THE ROUTINE SEARCHES FOR C THE EXACT MAXIMUM EXPONENT FOR THE FLOATING C POINT NUMBERS. IF MAXEXP IS POSITIVE ON INPUT C THEN THE SEARCH BEGINS WITH MAXEXP. IF C MAXEXP .LE. 0 ON INPUT THEN THE ROUTINE BEGINS C THE SEARCH WITH ITS OWN INITIAL APPROXIMATION C FOR MAXEXP. THE FOLLOWING LOOP IS PERFORMED. C (1) CHECK THE CURRENT VALUE OF MAXEXP C FOR OVERFLOW. IF OVERFLOW OCCURS C THEN THE ROUTINE WILL (HOPEFULLY) C ABORT. OTHERWISE, IF OVERFLOW DOES C NOT OCCUR THEN GO TO (2). C (2) WRITE ON UNIT N THE CURRENT VALUE C OF MAXEXP AND GO TO (3). C (3) INCREASE THE VALUE OF MAXEXP BY 1 C AND RETURN TO (1). C IF THE OVERFLOW TEST IN (1) FAILS THEN THE C ROUTINE ABORTS AFTER 500 PASSES THROUGH THE C LOOP. IF THE OVERFLOW TEST WORKS PROPERLY C THEN THE LAST INTEGER WRITTEN ON UNIT N IS C THE DESIRED MAXIMUM EXPONENT FOR THE FLOAT- C ING POINT NUMBERS. RESET MAXEXP TO THIS C INTEGER, SET N = 0, AND RERUN THE ROUTINE. C C EPS - THE RELATIVE PRECISION OF THE FLOATING ARITHMETIC. C EPS = B**(1 - M) WHERE B = DBLE(FLOAT(IBETA)). C C XINT - THE LARGEST POSITIVE INTEGER THAT CAN C BE EXACTLY REPRESENTED AS A FLOATING C POINT NUMBER. XINT = B**M - 1 WHERE C B = DBLE(FLOAT(IBETA)). C C XMIN - THE SMALLEST NONZERO POWER OF THE BASE. C XMIN = B**(MINEXP-1) WHERE B=DBLE(FLOAT(IBETA)). C C XMAX - THE LARGEST FOATING POINT NUMBER THAT CAN C BE OBTAINED HAVING THE EXPONENT MAXEXP. C XMAX = (1 - B**(-M)) * B**MAXEXP WHERE C B = DBLE(FLOAT(IBETA)). IF MAXEXP IS THE C MAXIMUM EXPONENT FOR THE FLOATING POINT C NUMBERS THEN XMAX IS THE LARGEST FLOATING C POINT NUMBER THAT EXISTS. THE VALUE C OBTAINED FOR XMAX MAY BE AFFECTED SLIGHTLY C BY ROUNDOFF ERROR. C C----------------------------------------------------------------------- DOUBLE PRECISION B,B2, BINV, BM1, D1, D2, ONE, P, Q, T, X, Z, ZERO C---------------- COMMON /DPDATA/ D1, D2 C ZERO = DBLE(FLOAT(0)) ONE = DBLE(FLOAT(1)) B = DBLE(FLOAT(IBETA)) B2 = B*B BM1 = DBLE(FLOAT(IBETA - 1)) BINV = ONE/B C----------------------------------------------------------------------- C COMPUTE M AND EPS C----------------------------------------------------------------------- M = 1 T = B 10 M = M + 1 Z = T T = B*T CALL DSTOR2 (T + ONE, T) X = D1*BINV - Z IF (X .EQ. BINV) GO TO 10 C XINT = (Z - ONE)*B + BM1 XMAX = XINT/T IF (XMAX .LT. ONE) GO TO 20 M = M - 1 T = Z Z = Z*BINV XINT = (Z - ONE)*B + BM1 XMAX = XINT/T 20 EPS = ONE/Z C----------------------------------------------------------------------- C COMPUTE MINEXP AND XMIN C----------------------------------------------------------------------- P = ONE + EPS Q = ONE + EPS*B2 C C MINEXP MUST BE FOUND. THIS LOOP OBTAINS THE LARGEST C K = 2**I SUCH THAT B**(-K) DOES NOT UNDERFLOW. C K = 1 Z = BINV 30 X = Z Z = (X*X)*ONE CALL DSTOR2 (Z*XINT, Z*T) IF (D1 .EQ. D2) GO TO 40 IF (Z + Z .EQ. ZERO .OR. DABS(Z) .GE. X) GO TO 40 CALL DSTOR2 (Z, P*Z) IF (T*D2 .EQ. T*Z) GO TO 40 K = K + K GO TO 30 C 40 KM = K + K J = 0 C C LOOP TO DETERMINE MINEXP AND XMIN C 50 XMIN = X X = (X*BINV)*ONE CALL DSTOR2 (X*XINT, X*T) IF (D1 .EQ. D2) GO TO 90 IF (X + X .EQ. ZERO .OR. DABS(X) .GE. XMIN) GO TO 90 CALL DSTOR2 (X, P*X) IF (T*D2 .EQ. T*X) GO TO 80 K = K + 1 GO TO 50 C C IF THERE IS LOSS OF ACCURACY NOT DUE TO UNDERFLOW C THEN SET J = NUMBER OF DIGITS POSSIBLY LOST DUE TO C THIS LOSS OF ACCURACY. C 80 CALL DSTOR2 (X, Q*X) IF (T*D2 .NE. T*X) GO TO 90 81 Z = X J = J + 1 X = (X*BINV)*ONE CALL DSTOR2 (X*XINT, X*T) IF (D1 .EQ. D2) GO TO 90 IF (X + X .NE. ZERO .AND. DABS(X) .LT. Z) GO TO 81 C 90 MINEXP = 1 - K C----------------------------------------------------------------------- C DEFINE AN INITIAL APPROXIMATION FOR MAXEXP AND XMIN C WHEN MAXEXP .LE. 0 ON INPUT C----------------------------------------------------------------------- IF (MAXEXP .GT. 0) GO TO 101 IF (IBETA .EQ. 2 .OR. IBETA .EQ. 8 .OR. * IBETA .EQ. 16) GO TO 100 C MAXEXP = K - 3 IF (N .GT. 0) WRITE (N,200) MAXEXP T = ONE/(B2*B2*XMIN) XMAX = (XMAX*T)*B GO TO 110 C 100 K = K + J IF (K + K .GT. KM + 2) KM = KM + KM MAXEXP = KM - K - 3 101 IF (N .GT. 0) WRITE (N,200) MAXEXP T = B**(MAXEXP - 2) XMAX = ((XMAX*T)*B)*B C----------------------------------------------------------------------- C CHECK THE APPROXIMATION FOR MAXEXP C----------------------------------------------------------------------- 110 CALL DSTOR2 (T, T*P) IF (D1 .EQ. D2) GO TO 150 IF (N .LE. 0) RETURN C----------------------------------------------------------------------- C LOOP TO FIND THE EXACT LARGEST VALUE FOR MAXEXP C----------------------------------------------------------------------- WRITE (N,210) MAXEXP DO 120 L = 1,500 T = T*B XMAX = XMAX*B MAXEXP = MAXEXP + 1 CALL DSTOR2 (T, T*P) IF (D1 .EQ. D2) GO TO 150 WRITE (N,220) MAXEXP 120 CONTINUE WRITE (N,240) STOP C----------------------------------------------------------------------- C REPORTING OVERFLOW ON UNIT N C----------------------------------------------------------------------- 150 IF (N .GT. 0) WRITE (N,230) STOP C----------------------------------------------------------------------- C FORMAT STATEMENTS C----------------------------------------------------------------------- 200 FORMAT (51H THE INITIAL APPROXIMATION FOR IDMAX (OR MAXEXP) IS// * I25// * 47H IF NO FURTHER INFORMATION APPEARS ON THIS FILE/ * 51H THEN SET IDMAX (OR MAXEXP) TO A SMALLER VALUE THAN/ * 39H THIS APPROXIMATION AND RERUN THE CODE.//) 210 FORMAT (51H THE LOOP TO FIND THE LARGEST POSSIBLE EXPONENT HAS/ * 49H BEGUN. SET IDMAX (OR MAXEXP) TO THE LAST INTEGER/ * 14H THAT FOLLOWS.//I25) 220 FORMAT (I25) 230 FORMAT (32H0 ****** OVERFLOW OCCURS ******) 240 FORMAT(/46H ****** 500 PASSES WERE MADE THROUGH THE LOOP./ * 45H THE MAXIMUM EXPONENT CANNOT BE FOUND./ * 44H IF ONE WISHES, SET IDMAX (OR MAXEXP)/ * 45H TO A LARGER VALUE AND RERUN THE CODE./) C----------------------------------------------------------------------- END SUBROUTINE DSTOR2 (A, B) C----------------------------------------------------------------------- C STORAGE OF DOUBLE PRECISION INFORMATION INTO MEMORY C----------------------------------------------------------------------- DOUBLE PRECISION A, B, D1, D2 COMMON /DPDATA/ D1, D2 D1 = A D2 = B RETURN END REAL FUNCTION SPMPAR (I) C----------------------------------------------------------------------- C C SPMPAR PROVIDES THE SINGLE PRECISION MACHINE CONSTANTS FOR C THE COMPUTER BEING USED. IT IS ASSUMED THAT THE ARGUMENT C I IS AN INTEGER HAVING ONE OF THE VALUES 1, 2, OR 3. IF THE C SINGLE PRECISION ARITHMETIC BEING USED HAS M BASE B DIGITS AND C ITS SMALLEST AND LARGEST EXPONENTS ARE EMIN AND EMAX, THEN C C SPMPAR(1) = B**(1 - M), THE MACHINE PRECISION, C C SPMPAR(2) = B**(EMIN - 1), THE SMALLEST MAGNITUDE, C C SPMPAR(3) = B**EMAX*(1 - B**(-M)), THE LARGEST MAGNITUDE. C C----------------------------------------------------------------------- C WRITTEN BY C ALFRED H. MORRIS, JR. C NAVAL SURFACE WARFARE CENTER C DAHLGREN VIRGINIA C----------------------------------------------------------------------- INTEGER EMIN, EMAX C IF (I .GT. 1) GO TO 10 B = IPMPAR(4) M = IPMPAR(5) SPMPAR = B**(1 - M) RETURN C 10 IF (I .GT. 2) GO TO 20 B = IPMPAR(4) EMIN = IPMPAR(6) ONE = FLOAT(1) BINV = ONE/B W = B**(EMIN + 2) SPMPAR = ((W * BINV) * BINV) * BINV RETURN C 20 IBETA = IPMPAR(4) M = IPMPAR(5) EMAX = IPMPAR(7) C B = IBETA BM1 = IBETA - 1 ONE = FLOAT(1) Z = B**(M - 1) W = ((Z - ONE)*B + BM1)/(B*Z) C Z = B**(EMAX - 2) SPMPAR = ((W * Z) * B) * B RETURN END DOUBLE PRECISION FUNCTION DPMPAR (I) C----------------------------------------------------------------------- C C DPMPAR PROVIDES THE DOUBLE PRECISION MACHINE CONSTANTS FOR C THE COMPUTER BEING USED. IT IS ASSUMED THAT THE ARGUMENT C I IS AN INTEGER HAVING ONE OF THE VALUES 1, 2, OR 3. IF THE C DOUBLE PRECISION ARITHMETIC BEING USED HAS M BASE B DIGITS AND C ITS SMALLEST AND LARGEST EXPONENTS ARE EMIN AND EMAX, THEN C C DPMPAR(1) = B**(1 - M), THE MACHINE PRECISION, C C DPMPAR(2) = B**(EMIN - 1), THE SMALLEST MAGNITUDE, C C DPMPAR(3) = B**EMAX*(1 - B**(-M)), THE LARGEST MAGNITUDE. C C----------------------------------------------------------------------- C WRITTEN BY C ALFRED H. MORRIS, JR. C NAVAL SURFACE WARFARE CENTER C DAHLGREN VIRGINIA C----------------------------------------------------------------------- INTEGER EMIN, EMAX DOUBLE PRECISION B, BINV, BM1, ONE, W, Z C IF (I .GT. 1) GO TO 10 B = IPMPAR(4) M = IPMPAR(8) DPMPAR = B**(1 - M) RETURN C 10 IF (I .GT. 2) GO TO 20 B = IPMPAR(4) EMIN = IPMPAR(9) ONE = FLOAT(1) BINV = ONE/B W = B**(EMIN + 2) DPMPAR = ((W * BINV) * BINV) * BINV RETURN C 20 IBETA = IPMPAR(4) M = IPMPAR(8) EMAX = IPMPAR(10) C B = IBETA BM1 = IBETA - 1 ONE = FLOAT(1) Z = B**(M - 1) W = ((Z - ONE)*B + BM1)/(B*Z) C Z = B**(EMAX - 2) DPMPAR = ((W * Z) * B) * B RETURN END REAL FUNCTION EPSLN (L) C-------------------------------------------------------------------- C THE EVALUATION OF LN(EPS) WHERE EPS IS THE SMALLEST NUMBER C SUCH THAT 1.0 + EPS .GT. 1.0 . L IS A DUMMY ARGUMENT. C-------------------------------------------------------------------- INTEGER B REAL LNB C B = IPMPAR(4) IF (B .NE. 2) GO TO 10 LNB = .69314718055995 GO TO 50 10 IF (B .NE. 8) GO TO 20 LNB = 2.0794415416798 GO TO 50 20 IF (B .NE. 16) GO TO 30 LNB = 2.7725887222398 GO TO 50 30 LNB = ALOG(FLOAT(B)) C 50 M = 1 - IPMPAR(5) EPSLN = M * LNB RETURN END DOUBLE PRECISION FUNCTION DEPSLN (L) C-------------------------------------------------------------------- C THE EVALUATION OF LN(EPS) WHERE EPS IS THE SMALLEST NUMBER C SUCH THAT 1.D0 + EPS .GT. 1.D0 . L IS A DUMMY ARGUMENT. C-------------------------------------------------------------------- INTEGER B DOUBLE PRECISION DB, LNB, M C B = IPMPAR(4) IF (B .NE. 2) GO TO 10 LNB = .693147180559945309417232121458D+00 GO TO 50 10 IF (B .NE. 8) GO TO 20 LNB = 2.07944154167983592825169636437D+00 GO TO 50 20 IF (B .NE. 16) GO TO 30 LNB = 2.77258872223978123766892848583D+00 GO TO 50 30 DB = B LNB = DLOG(DB) C 50 M = 1 - IPMPAR(8) DEPSLN = M * LNB RETURN END REAL FUNCTION EXPARG (L) C-------------------------------------------------------------------- C IF L = 0 THEN EXPARG(L) = THE LARGEST POSITIVE W FOR WHICH C EXP(W) CAN BE COMPUTED. C C IF L IS NONZERO THEN EXPARG(L) = THE LARGEST NEGATIVE W FOR C WHICH THE COMPUTED VALUE OF EXP(W) IS NONZERO. C C NOTE... ONLY AN APPROXIMATE VALUE FOR EXPARG(L) IS NEEDED. C-------------------------------------------------------------------- INTEGER B REAL LNB C B = IPMPAR(4) IF (B .NE. 2) GO TO 10 LNB = .69314718055995 GO TO 50 10 IF (B .NE. 8) GO TO 20 LNB = 2.0794415416798 GO TO 50 20 IF (B .NE. 16) GO TO 30 LNB = 2.7725887222398 GO TO 50 30 LNB = ALOG(FLOAT(B)) C 50 IF (L .EQ. 0) GO TO 60 M = IPMPAR(6) - 1 EXPARG = 0.99999 * (M * LNB) RETURN 60 M = IPMPAR(7) EXPARG = 0.99999 * (M * LNB) RETURN END DOUBLE PRECISION FUNCTION DXPARG (L) C-------------------------------------------------------------------- C IF L = 0 THEN DXPARG(L) = THE LARGEST POSITIVE W FOR WHICH C DEXP(W) CAN BE COMPUTED. C C IF L IS NONZERO THEN DXPARG(L) = THE LARGEST NEGATIVE W FOR C WHICH THE COMPUTED VALUE OF DEXP(W) IS NONZERO. C C NOTE... ONLY AN APPROXIMATE VALUE FOR DXPARG(L) IS NEEDED. C-------------------------------------------------------------------- INTEGER B DOUBLE PRECISION DB, LNB C B = IPMPAR(4) IF (B .NE. 2) GO TO 10 LNB = .693147180559945309417232121458D+00 GO TO 50 10 IF (B .NE. 8) GO TO 20 LNB = 2.07944154167983592825169636437D+00 GO TO 50 20 IF (B .NE. 16) GO TO 30 LNB = 2.77258872223978123766892848583D+00 GO TO 50 30 DB = B LNB = DLOG(DB) C 50 IF (L .EQ. 0) GO TO 60 M = IPMPAR(9) - 1 DXPARG = 0.999999999999D+00 * (M * LNB) RETURN 60 M = IPMPAR(10) DXPARG = 0.999999999999D+00 * (M * LNB) RETURN END SUBROUTINE ISHELL (A, N) C----------------------------------------------------------------------- C THE SHELL SORTING PROCEDURE IS USED TO REORDER THE ELEMENTS OF A C SO THAT A(I).LE.A(I+1) FOR I=1,...,N-1. IT IS ASSUMED THAT N.GE.1. C----------------------------------------------------------------------- INTEGER A(N), K(10), S C------------------------ DATA K(1)/1/, K(2)/4/, K(3)/13/, K(4)/40/, K(5)/121/, K(6)/364/, 1 K(7)/1093/, K(8)/3280/, K(9)/9841/, K(10)/29524/ C------------------------ C C SELECTION OF THE INCREMENTS K(I) = (3**I-1)/2 C IF (N .LT. 2) RETURN IMAX = 1 DO 10 I = 3,10 IF (N .LE. K(I)) GO TO 20 IMAX = IMAX + 1 10 CONTINUE C C STEPPING THROUGH THE INCREMENTS K(IMAX),...,K(1) C 20 I = IMAX DO 40 II = 1,IMAX KI = K(I) C C SORTING ELEMENTS THAT ARE KI POSITIONS APART C SO THAT A(J).LE.A(J+KI) FOR J=1,...,N-KI C JMAX = N - KI DO 31 J = 1,JMAX L = J LL = J + KI S = A(LL) 30 IF (S .GE. A(L)) GO TO 31 A(LL) = A(L) LL = L L = L - KI IF (L .GT. 0) GO TO 30 31 A(LL) = S C 40 I = I - 1 RETURN END SUBROUTINE SHELL (A, N) C----------------------------------------------------------------------- C THE SHELL SORTING PROCEDURE IS USED TO REORDER THE ELEMENTS OF A C SO THAT A(I).LE.A(I+1) FOR I=1,...,N-1. IT IS ASSUMED THAT N.GE.1. C----------------------------------------------------------------------- REAL A(N) INTEGER K(10) C------------------------ DATA K(1)/1/, K(2)/4/, K(3)/13/, K(4)/40/, K(5)/121/, K(6)/364/, 1 K(7)/1093/, K(8)/3280/, K(9)/9841/, K(10)/29524/ C------------------------ C C SELECTION OF THE INCREMENTS K(I) = (3**I-1)/2 C IF (N .LT. 2) RETURN IMAX = 1 DO 10 I = 3,10 IF (N .LE. K(I)) GO TO 20 IMAX = IMAX + 1 10 CONTINUE C C STEPPING THROUGH THE INCREMENTS K(IMAX),...,K(1) C 20 I = IMAX DO 40 II = 1,IMAX KI = K(I) C C SORTING ELEMENTS THAT ARE KI POSITIONS APART C SO THAT A(J).LE.A(J+KI) FOR J=1,...,N-KI C JMAX = N - KI DO 31 J = 1,JMAX L = J LL = J + KI S = A(LL) 30 IF (S .GE. A(L)) GO TO 31 A(LL) = A(L) LL = L L = L - KI IF (L .GT. 0) GO TO 30 31 A(LL) = S C 40 I = I - 1 RETURN END SUBROUTINE SHELL2 (A, B, N) C----------------------------------------------------------------------- C THE SHELL SORTING PROCEDURE IS USED TO REORDER THE ELEMENTS OF A C SO THAT A(I).LE.A(I+1) FOR I=1,...,N-1. THE SAME PERMUTATIONS ARE C PERFORMED ON B THAT ARE PERFORMED ON A. IT IS ASSUMED THAT N.GE.1. C----------------------------------------------------------------------- REAL A(N), B(N) INTEGER K(10) C------------------------ DATA K(1)/1/, K(2)/4/, K(3)/13/, K(4)/40/, K(5)/121/, K(6)/364/, 1 K(7)/1093/, K(8)/3280/, K(9)/9841/, K(10)/29524/ C------------------------ C C SELECTION OF THE INCREMENTS K(I) = (3**I-1)/2 C IF (N .LT. 2) RETURN IMAX = 1 DO 10 I = 3,10 IF (N .LE. K(I)) GO TO 20 IMAX = IMAX + 1 10 CONTINUE C C STEPPING THROUGH THE INCREMENTS K(IMAX),...,K(1) C 20 I = IMAX DO 40 II = 1,IMAX KI = K(I) C C SORTING ELEMENTS THAT ARE KI POSITIONS APART C SO THAT A(J).LE.A(J+KI) FOR J=1,...,N-KI C JMAX = N - KI DO 32 J = 1,JMAX L = J LL = J + KI S = A(LL) T = B(LL) 30 IF (S .GE. A(L)) GO TO 31 A(LL) = A(L) B(LL) = B(L) LL = L L = L - KI IF (L .GT. 0) GO TO 30 31 A(LL) = S B(LL) = T 32 CONTINUE C 40 I = I - 1 RETURN END SUBROUTINE RSORT (A, N) C----------------------------------------------------------------------- C THE SHELL SORTING PROCEDURE IS USED TO REORDER THE ELEMENTS OF A C SO THAT A(I).LE.A(I+1) FOR I=1,...,N-1. IT IS ASSUMED THAT N.GE.1. C----------------------------------------------------------------------- REAL A(N) INTEGER K(10) C------------------------ DATA K(1)/1/, K(2)/4/, K(3)/13/, K(4)/40/, K(5)/121/, K(6)/364/, 1 K(7)/1093/, K(8)/3280/, K(9)/9841/, K(10)/29524/ C------------------------ C C SELECTION OF THE INCREMENTS K(I) = (3**I-1)/2 C IF (N .LT. 2) RETURN IMAX = 1 DO 10 I = 3,10 IF (N .LE. K(I)) GO TO 20 IMAX = IMAX + 1 10 CONTINUE C C STEPPING THROUGH THE INCREMENTS K(IMAX),...,K(1) C 20 I = IMAX DO 40 II = 1,IMAX KI = K(I) C C SORTING ELEMENTS THAT ARE KI POSITIONS APART C SO THAT A(J).LE.A(J+KI) FOR J=1,...,N-KI C JMAX = N - KI DO 31 J = 1,JMAX L = J LL = J + KI S = A(LL) 30 IF (S .GE. A(L)) GO TO 31 A(LL) = A(L) LL = L L = L - KI IF (L .GT. 0) GO TO 30 31 A(LL) = S C 40 I = I - 1 RETURN END SUBROUTINE RISORT (A, M, N) C----------------------------------------------------------------------- C THE SHELL SORTING PROCEDURE IS USED TO REORDER THE ELEMENTS OF A C SO THAT A(I).LE.A(I+1) FOR I=1,...,N-1. THE SAME PERMUTATIONS ARE C PERFORMED ON M THAT ARE PERFORMED ON A. IT IS ASSUMED THAT N.GE.1. C----------------------------------------------------------------------- REAL A(N) INTEGER M(N), T INTEGER K(10) C------------------------ DATA K(1)/1/, K(2)/4/, K(3)/13/, K(4)/40/, K(5)/121/, K(6)/364/, 1 K(7)/1093/, K(8)/3280/, K(9)/9841/, K(10)/29524/ C------------------------ C C SELECTION OF THE INCREMENTS K(I) = (3**I-1)/2 C IF (N .LT. 2) RETURN IMAX = 1 DO 10 I = 3,10 IF (N .LE. K(I)) GO TO 20 IMAX = IMAX + 1 10 CONTINUE C C STEPPING THROUGH THE INCREMENTS K(IMAX),...,K(1) C 20 I = IMAX DO 40 II = 1,IMAX KI = K(I) C C SORTING ELEMENTS THAT ARE KI POSITIONS APART C SO THAT A(J).LE.A(J+KI) FOR J=1,...,N-KI C JMAX = N - KI DO 32 J = 1,JMAX L = J LL = J + KI S = A(LL) T = M(LL) 30 IF (S .GE. A(L)) GO TO 31 A(LL) = A(L) M(LL) = M(L) LL = L L = L - KI IF (L .GT. 0) GO TO 30 31 A(LL) = S M(LL) = T 32 CONTINUE C 40 I = I - 1 RETURN END SUBROUTINE RRSORT (A, B, N) C----------------------------------------------------------------------- C THE SHELL SORTING PROCEDURE IS USED TO REORDER THE ELEMENTS OF A C SO THAT A(I).LE.A(I+1) FOR I=1,...,N-1. THE SAME PERMUTATIONS ARE C PERFORMED ON B THAT ARE PERFORMED ON A. IT IS ASSUMED THAT N.GE.1. C----------------------------------------------------------------------- REAL A(N), B(N) INTEGER K(10) C------------------------ DATA K(1)/1/, K(2)/4/, K(3)/13/, K(4)/40/, K(5)/121/, K(6)/364/, 1 K(7)/1093/, K(8)/3280/, K(9)/9841/, K(10)/29524/ C------------------------ C C SELECTION OF THE INCREMENTS K(I) = (3**I-1)/2 C IF (N .LT. 2) RETURN IMAX = 1 DO 10 I = 3,10 IF (N .LE. K(I)) GO TO 20 IMAX = IMAX + 1 10 CONTINUE C C STEPPING THROUGH THE INCREMENTS K(IMAX),...,K(1) C 20 I = IMAX DO 40 II = 1,IMAX KI = K(I) C C SORTING ELEMENTS THAT ARE KI POSITIONS APART C SO THAT A(J).LE.A(J+KI) FOR J=1,...,N-KI C JMAX = N - KI DO 32 J = 1,JMAX L = J LL = J + KI S = A(LL) T = B(LL) 30 IF (S .GE. A(L)) GO TO 31 A(LL) = A(L) B(LL) = B(L) LL = L L = L - KI IF (L .GT. 0) GO TO 30 31 A(LL) = S B(LL) = T 32 CONTINUE C 40 I = I - 1 RETURN END SUBROUTINE DSORT (A, N) C----------------------------------------------------------------------- C THE SHELL SORTING PROCEDURE IS USED TO REORDER THE ELEMENTS OF A C SO THAT A(I).LE.A(I+1) FOR I=1,...,N-1. IT IS ASSUMED THAT N.GE.1. C----------------------------------------------------------------------- DOUBLE PRECISION A(N), S INTEGER K(10) C------------------------ DATA K(1)/1/, K(2)/4/, K(3)/13/, K(4)/40/, K(5)/121/, K(6)/364/, 1 K(7)/1093/, K(8)/3280/, K(9)/9841/, K(10)/29524/ C------------------------ C C SELECTION OF THE INCREMENTS K(I) = (3**I-1)/2 C IF (N .LT. 2) RETURN IMAX = 1 DO 10 I = 3,10 IF (N .LE. K(I)) GO TO 20 IMAX = IMAX + 1 10 CONTINUE C C STEPPING THROUGH THE INCREMENTS K(IMAX),...,K(1) C 20 I = IMAX DO 40 II = 1,IMAX KI = K(I) C C SORTING ELEMENTS THAT ARE KI POSITIONS APART C SO THAT A(J).LE.A(J+KI) FOR J=1,...,N-KI C JMAX = N - KI DO 31 J = 1,JMAX L = J LL = J + KI S = A(LL) 30 IF (S .GE. A(L)) GO TO 31 A(LL) = A(L) LL = L L = L - KI IF (L .GT. 0) GO TO 30 31 A(LL) = S C 40 I = I - 1 RETURN END SUBROUTINE DISORT (A, M, N) C----------------------------------------------------------------------- C THE SHELL SORTING PROCEDURE IS USED TO REORDER THE ELEMENTS OF A C SO THAT A(I).LE.A(I+1) FOR I=1,...,N-1. THE SAME PERMUTATIONS ARE C PERFORMED ON M THAT ARE PERFORMED ON A. IT IS ASSUMED THAT N.GE.1. C----------------------------------------------------------------------- DOUBLE PRECISION A(N), S INTEGER M(N), T INTEGER K(10) C------------------------ DATA K(1)/1/, K(2)/4/, K(3)/13/, K(4)/40/, K(5)/121/, K(6)/364/, 1 K(7)/1093/, K(8)/3280/, K(9)/9841/, K(10)/29524/ C------------------------ C C SELECTION OF THE INCREMENTS K(I) = (3**I-1)/2 C IF (N .LT. 2) RETURN IMAX = 1 DO 10 I = 3,10 IF (N .LE. K(I)) GO TO 20 IMAX = IMAX + 1 10 CONTINUE C C STEPPING THROUGH THE INCREMENTS K(IMAX),...,K(1) C 20 I = IMAX DO 40 II = 1,IMAX KI = K(I) C C SORTING ELEMENTS THAT ARE KI POSITIONS APART C SO THAT A(J).LE.A(J+KI) FOR J=1,...,N-KI C JMAX = N - KI DO 32 J = 1,JMAX L = J LL = J + KI S = A(LL) T = M(LL) 30 IF (S .GE. A(L)) GO TO 31 A(LL) = A(L) M(LL) = M(L) LL = L L = L - KI IF (L .GT. 0) GO TO 30 31 A(LL) = S M(LL) = T 32 CONTINUE C 40 I = I - 1 RETURN END SUBROUTINE DDSORT (A, B, N) C----------------------------------------------------------------------- C THE SHELL SORTING PROCEDURE IS USED TO REORDER THE ELEMENTS OF A C SO THAT A(I).LE.A(I+1) FOR I=1,...,N-1. THE SAME PERMUTATIONS ARE C PERFORMED ON B THAT ARE PERFORMED ON A. IT IS ASSUMED THAT N.GE.1. C----------------------------------------------------------------------- DOUBLE PRECISION A(N), B(N), S, T INTEGER K(10) C------------------------ DATA K(1)/1/, K(2)/4/, K(3)/13/, K(4)/40/, K(5)/121/, K(6)/364/, 1 K(7)/1093/, K(8)/3280/, K(9)/9841/, K(10)/29524/ C------------------------ C C SELECTION OF THE INCREMENTS K(I) = (3**I-1)/2 C IF (N .LT. 2) RETURN IMAX = 1 DO 10 I = 3,10 IF (N .LE. K(I)) GO TO 20 IMAX = IMAX + 1 10 CONTINUE C C STEPPING THROUGH THE INCREMENTS K(IMAX),...,K(1) C 20 I = IMAX DO 40 II = 1,IMAX KI = K(I) C C SORTING ELEMENTS THAT ARE KI POSITIONS APART C SO THAT A(J).LE.A(J+KI) FOR J=1,...,N-KI C JMAX = N - KI DO 32 J = 1,JMAX L = J LL = J + KI S = A(LL) T = B(LL) 30 IF (S .GE. A(L)) GO TO 31 A(LL) = A(L) B(LL) = B(L) LL = L L = L - KI IF (L .GT. 0) GO TO 30 31 A(LL) = S B(LL) = T 32 CONTINUE C 40 I = I - 1 RETURN END SUBROUTINE AORD (A, N) C----------------------------------------------------------------------- C THE AORD SORTING PROCEDURE IS USED TO REORDER THE ELEMENTS OF C A SO THAT ABS(A(I)) .LE. ABS(A(I+1)) FOR I = 1,...,N-1. IT IS C ASSUMED THAT N .GE. 1. C----------------------------------------------------------------------- REAL A(N) INTEGER K(10) C------------------------ DATA K(1)/1/, K(2)/4/, K(3)/13/, K(4)/40/, K(5)/121/, K(6)/364/, * K(7)/1093/, K(8)/3280/, K(9)/9841/, K(10)/29524/ C------------------------ C C SELECTION OF THE INCREMENTS K(I) = (3**I-1)/2 C IF (N .LT. 2) RETURN IMAX = 1 DO 10 I = 3,10 IF (N .LE. K(I)) GO TO 20 IMAX = IMAX + 1 10 CONTINUE C C STEPPING THROUGH THE INCREMENTS K(IMAX),...,K(1) C 20 I = IMAX DO 40 II = 1,IMAX KI = K(I) C C SORTING ELEMENTS THAT ARE KI POSITIONS APART C SO THAT ABS(A(J)) .LE. ABS(A(J+KI)) C JMAX = N - KI DO 31 J = 1,JMAX L = J LL = J + KI S = A(LL) 30 IF (ABS(S) .GE. ABS(A(L))) GO TO 31 A(LL) = A(L) LL = L L = L - KI IF (L .GT. 0) GO TO 30 31 A(LL) = S C 40 I = I - 1 RETURN END SUBROUTINE DAORD (A, N) C----------------------------------------------------------------------- C DAORD IS USED TO REORDER THE ELEMENTS OF THE DOUBLE PRECISION C ARRAY A SO THAT DABS(A(I)) .LE. DABS(A(I+1)) FOR I = 1,...,N-1. C IT IS ASSUMED THAT N .GE. 1. C----------------------------------------------------------------------- DOUBLE PRECISION A(N), S INTEGER K(10) C------------------------ DATA K(1)/1/, K(2)/4/, K(3)/13/, K(4)/40/, K(5)/121/, K(6)/364/, * K(7)/1093/, K(8)/3280/, K(9)/9841/, K(10)/29524/ C------------------------ C C SELECTION OF THE INCREMENTS K(I) = (3**I-1)/2 C IF (N .LT. 2) RETURN IMAX = 1 DO 10 I = 3,10 IF (N .LE. K(I)) GO TO 20 IMAX = IMAX + 1 10 CONTINUE C C STEPPING THROUGH THE INCREMENTS K(IMAX),...,K(1) C 20 I = IMAX DO 40 II = 1,IMAX KI = K(I) C C SORTING ELEMENTS THAT ARE KI POSITIONS APART C SO THAT DABS(A(J)) .LE. DABS(A(J+KI)) C JMAX = N - KI DO 31 J = 1,JMAX L = J LL = J + KI S = A(LL) 30 IF (DABS(S) .GE. DABS(A(L))) GO TO 31 A(LL) = A(L) LL = L L = L - KI IF (L .GT. 0) GO TO 30 31 A(LL) = S C 40 I = I - 1 RETURN END SUBROUTINE QSORTI (X, IND, N) INTEGER N, X(N), IND(N) C C*********************************************************** C C ROBERT RENKA C OAK RIDGE NATL. LAB. C C THIS SUBROUTINE USES AN ORDER N*LOG(N) QUICK SORT TO C SORT AN INTEGER ARRAY X INTO INCREASING ORDER. THE ALGOR- C ITHM IS AS FOLLOWS. IND IS INITIALIZED TO THE ORDERED C SEQUENCE OF INDICES 1,...,N, AND ALL INTERCHANGES ARE C APPLIED TO IND. X IS DIVIDED INTO TWO PORTIONS BY PICKING C A CENTRAL ELEMENT T. THE FIRST AND LAST ELEMENTS ARE COM- C PARED WITH T, AND INTERCHANGES ARE APPLIED AS NECESSARY SO C THAT THE THREE VALUES ARE IN ASCENDING ORDER. INTER- C CHANGES ARE THEN APPLIED SO THAT ALL ELEMENTS GREATER THAN C T ARE IN THE UPPER PORTION OF THE ARRAY AND ALL ELEMENTS C LESS THAN T ARE IN THE LOWER PORTION. THE UPPER AND LOWER C INDICES OF ONE OF THE PORTIONS ARE SAVED IN LOCAL ARRAYS, C AND THE PROCESS IS REPEATED ITERATIVELY ON THE OTHER C PORTION. WHEN A PORTION IS COMPLETELY SORTED, THE PROCESS C BEGINS AGAIN BY RETRIEVING THE INDICES BOUNDING ANOTHER C UNSORTED PORTION. C C INPUT PARAMETERS - N - LENGTH OF THE ARRAY X. C C X - VECTOR OF LENGTH N TO BE SORTED. C C IND - VECTOR OF LENGTH .GE. N. C C N AND X ARE NOT ALTERED BY THIS ROUTINE. C C OUTPUT PARAMETER - IND - SEQUENCE OF INDICES 1,...,N C PERMUTED IN THE SAME FASHION AS X C WOULD BE. THUS, THE ORDERING ON C X IS DEFINED BY Y(I) = X(IND(I)). C C INTRINSIC FUNCTIONS CALLED BY QSORTI - IFIX, FLOAT C C*********************************************************** C C NOTE -- IU AND IL MUST BE DIMENSIONED .GE. LOG(N) WHERE C LOG HAS BASE 2. C C*********************************************************** C INTEGER IU(21), IL(21) INTEGER M, I, J, K, L, IJ, IT, ITT, INDX, T REAL R C C LOCAL PARAMETERS - C C IU,IL = TEMPORARY STORAGE FOR THE UPPER AND LOWER C INDICES OF PORTIONS OF THE ARRAY X C M = INDEX FOR IU AND IL C I,J = LOWER AND UPPER INDICES OF A PORTION OF X C K,L = INDICES IN THE RANGE I,...,J C IJ = RANDOMLY CHOSEN INDEX BETWEEN I AND J C IT,ITT = TEMPORARY STORAGE FOR INTERCHANGES IN IND C INDX = TEMPORARY INDEX FOR X C R = PSEUDO RANDOM NUMBER FOR GENERATING IJ C T = CENTRAL ELEMENT OF X C IF (N .LE. 0) RETURN C C INITIALIZE IND, M, I, J, AND R C DO 1 I = 1,N 1 IND(I) = I M = 1 I = 1 J = N R = .375 C C TOP OF LOOP C 2 IF (I .GE. J) GO TO 10 IF (R .GT. .5898437) GO TO 3 R = R + .0390625 GO TO 4 3 R = R - .21875 C C INITIALIZE K C 4 K = I C C SELECT A CENTRAL ELEMENT OF X AND SAVE IT IN T C IJ = I + IFIX(R*FLOAT(J-I)) IT = IND(IJ) T = X(IT) C C IF THE FIRST ELEMENT OF THE ARRAY IS GREATER THAN T, C INTERCHANGE IT WITH T C INDX = IND(I) IF (X(INDX) .LE. T) GO TO 5 IND(IJ) = INDX IND(I) = IT IT = INDX T = X(IT) C C INITIALIZE L C 5 L = J C C IF THE LAST ELEMENT OF THE ARRAY IS LESS THAN T, C INTERCHANGE IT WITH T C INDX = IND(J) IF (X(INDX) .GE. T) GO TO 7 IND(IJ) = INDX IND(J) = IT IT = INDX T = X(IT) C C IF THE FIRST ELEMENT OF THE ARRAY IS GREATER THAN T, C INTERCHANGE IT WITH T C INDX = IND(I) IF (X(INDX) .LE. T) GO TO 7 IND(IJ) = INDX IND(I) = IT IT = INDX T = X(IT) GO TO 7 C C INTERCHANGE ELEMENTS K AND L C 6 ITT = IND(L) IND(L) = IND(K) IND(K) = ITT C C FIND AN ELEMENT IN THE UPPER PART OF THE ARRAY WHICH IS C NOT LARGER THAN T C 7 L = L - 1 INDX = IND(L) IF (X(INDX) .GT. T) GO TO 7 C C FIND AN ELEMENT IN THE LOWER PART OF THE ARRAY WHCIH IS C NOT SMALLER THAN T C 8 K = K + 1 INDX = IND(K) IF (X(INDX) .LT. T) GO TO 8 C C IF K .LE. L, INTERCHANGE ELEMENTS K AND L C IF (K .LE. L) GO TO 6 C C SAVE THE UPPER AND LOWER SUBSCRIPTS OF THE PORTION OF THE C ARRAY YET TO BE SORTED C IF (L-I .LE. J-K) GO TO 9 IL(M) = I IU(M) = L I = K M = M + 1 GO TO 11 C 9 IL(M) = K IU(M) = J J = L M = M + 1 GO TO 11 C C BEGIN AGAIN ON ANOTHER UNSORTED PORTION OF THE ARRAY C 10 M = M - 1 IF (M .EQ. 0) RETURN I = IL(M) J = IU(M) C 11 IF (J-I .GE. 11) GO TO 4 IF (I .EQ. 1) GO TO 2 I = I - 1 C C SORT ELEMENTS I+1,...,J. NOTE THAT 1 .LE. I .LT. J AND C J-I .LT. 11. C 12 I = I + 1 IF (I .EQ. J) GO TO 10 INDX = IND(I+1) T = X(INDX) IT = INDX INDX = IND(I) IF (X(INDX) .LE. T) GO TO 12 K = I C 13 IND(K+1) = IND(K) K = K - 1 INDX = IND(K) IF (T .LT. X(INDX)) GO TO 13 IND(K+1) = IT GO TO 12 END SUBROUTINE QSORTR (X, IND, N) INTEGER N, IND(N) REAL X(N) C C*********************************************************** C C ROBERT RENKA C OAK RIDGE NATL. LAB. C C THIS SUBROUTINE USES AN ORDER N*LOG(N) QUICK SORT TO C SORT THE REAL ARRAY X INTO INCREASING ORDER. THE ALGOR- C ITHM IS AS FOLLOWS. IND IS INITIALIZED TO THE ORDERED C SEQUENCE OF INDICES 1,...,N, AND ALL INTERCHANGES ARE C APPLIED TO IND. X IS DIVIDED INTO TWO PORTIONS BY PICKING C A CENTRAL ELEMENT T. THE FIRST AND LAST ELEMENTS ARE COM- C PARED WITH T, AND INTERCHANGES ARE APPLIED AS NECESSARY SO C THAT THE THREE VALUES ARE IN ASCENDING ORDER. INTER- C CHANGES ARE THEN APPLIED SO THAT ALL ELEMENTS GREATER THAN C T ARE IN THE UPPER PORTION OF THE ARRAY AND ALL ELEMENTS C LESS THAN T ARE IN THE LOWER PORTION. THE UPPER AND LOWER C INDICES OF ONE OF THE PORTIONS ARE SAVED IN LOCAL ARRAYS, C AND THE PROCESS IS REPEATED ITERATIVELY ON THE OTHER C PORTION. WHEN A PORTION IS COMPLETELY SORTED, THE PROCESS C BEGINS AGAIN BY RETRIEVING THE INDICES BOUNDING ANOTHER C UNSORTED PORTION. C C INPUT PARAMETERS - N - LENGTH OF THE ARRAY X. C C X - VECTOR OF LENGTH N TO BE SORTED. C C IND - VECTOR OF LENGTH .GE. N. C C N AND X ARE NOT ALTERED BY THIS ROUTINE. C C OUTPUT PARAMETER - IND - SEQUENCE OF INDICES 1,...,N C PERMUTED IN THE SAME FASHION AS X C WOULD BE. THUS, THE ORDERING ON C X IS DEFINED BY Y(I) = X(IND(I)). C C INTRINSIC FUNCTIONS CALLED BY QSORTR - IFIX, FLOAT C C*********************************************************** C C NOTE -- IU AND IL MUST BE DIMENSIONED .GE. LOG(N) WHERE C LOG HAS BASE 2. C C*********************************************************** C INTEGER IU(21), IL(21) INTEGER M, I, J, K, L, IJ, IT, ITT, INDX REAL R, T C C LOCAL PARAMETERS - C C IU,IL = TEMPORARY STORAGE FOR THE UPPER AND LOWER C INDICES OF PORTIONS OF THE ARRAY X C M = INDEX FOR IU AND IL C I,J = LOWER AND UPPER INDICES OF A PORTION OF X C K,L = INDICES IN THE RANGE I,...,J C IJ = RANDOMLY CHOSEN INDEX BETWEEN I AND J C IT,ITT = TEMPORARY STORAGE FOR INTERCHANGES IN IND C INDX = TEMPORARY INDEX FOR X C R = PSEUDO RANDOM NUMBER FOR GENERATING IJ C T = CENTRAL ELEMENT OF X C IF (N .LE. 0) RETURN C C INITIALIZE IND, M, I, J, AND R C DO 1 I = 1,N 1 IND(I) = I M = 1 I = 1 J = N R = .375 C C TOP OF LOOP C 2 IF (I .GE. J) GO TO 10 IF (R .GT. .5898437) GO TO 3 R = R + .0390625 GO TO 4 3 R = R - .21875 C C INITIALIZE K C 4 K = I C C SELECT A CENTRAL ELEMENT OF X AND SAVE IT IN T C IJ = I + IFIX(R*FLOAT(J-I)) IT = IND(IJ) T = X(IT) C C IF THE FIRST ELEMENT OF THE ARRAY IS GREATER THAN T, C INTERCHANGE IT WITH T C INDX = IND(I) IF (X(INDX) .LE. T) GO TO 5 IND(IJ) = INDX IND(I) = IT IT = INDX T = X(IT) C C INITIALIZE L C 5 L = J C C IF THE LAST ELEMENT OF THE ARRAY IS LESS THAN T, C INTERCHANGE IT WITH T C INDX = IND(J) IF (X(INDX) .GE. T) GO TO 7 IND(IJ) = INDX IND(J) = IT IT = INDX T = X(IT) C C IF THE FIRST ELEMENT OF THE ARRAY IS GREATER THAN T, C INTERCHANGE IT WITH T C INDX = IND(I) IF (X(INDX) .LE. T) GO TO 7 IND(IJ) = INDX IND(I) = IT IT = INDX T = X(IT) GO TO 7 C C INTERCHANGE ELEMENTS K AND L C 6 ITT = IND(L) IND(L) = IND(K) IND(K) = ITT C C FIND AN ELEMENT IN THE UPPER PART OF THE ARRAY WHICH IS C NOT LARGER THAN T C 7 L = L - 1 INDX = IND(L) IF (X(INDX) .GT. T) GO TO 7 C C FIND AN ELEMENT IN THE LOWER PART OF THE ARRAY WHCIH IS C NOT SMALLER THAN T C 8 K = K + 1 INDX = IND(K) IF (X(INDX) .LT. T) GO TO 8 C C IF K .LE. L, INTERCHANGE ELEMENTS K AND L C IF (K .LE. L) GO TO 6 C C SAVE THE UPPER AND LOWER SUBSCRIPTS OF THE PORTION OF THE C ARRAY YET TO BE SORTED C IF (L-I .LE. J-K) GO TO 9 IL(M) = I IU(M) = L I = K M = M + 1 GO TO 11 C 9 IL(M) = K IU(M) = J J = L M = M + 1 GO TO 11 C C BEGIN AGAIN ON ANOTHER UNSORTED PORTION OF THE ARRAY C 10 M = M - 1 IF (M .EQ. 0) RETURN I = IL(M) J = IU(M) C 11 IF (J-I .GE. 11) GO TO 4 IF (I .EQ. 1) GO TO 2 I = I - 1 C C SORT ELEMENTS I+1,...,J. NOTE THAT 1 .LE. I .LT. J AND C J-I .LT. 11. C 12 I = I + 1 IF (I .EQ. J) GO TO 10 INDX = IND(I+1) T = X(INDX) IT = INDX INDX = IND(I) IF (X(INDX) .LE. T) GO TO 12 K = I C 13 IND(K+1) = IND(K) K = K - 1 INDX = IND(K) IF (T .LT. X(INDX)) GO TO 13 IND(K+1) = IT GO TO 12 END SUBROUTINE QSORTD (X, IND, N) INTEGER N, IND(N) DOUBLE PRECISION X(N) C C*********************************************************** C C ROBERT RENKA C OAK RIDGE NATL. LAB. C C THIS SUBROUTINE USES AN ORDER N*LOG(N) QUICK SORT TO C SORT A DOUBLE PRECISION ARRAY X INTO INCREASING ORDER. THE C ALGORITHM IS AS FOLLOWS. IND IS INITIALIZED TO THE ORDERED C SEQUENCE OF INDICES 1,...,N, AND ALL INTERCHANGES ARE C APPLIED TO IND. X IS DIVIDED INTO TWO PORTIONS BY PICKING C A CENTRAL ELEMENT T. THE FIRST AND LAST ELEMENTS ARE COM- C PARED WITH T, AND INTERCHANGES ARE APPLIED AS NECESSARY SO C THAT THE THREE VALUES ARE IN ASCENDING ORDER. INTER- C CHANGES ARE THEN APPLIED SO THAT ALL ELEMENTS GREATER THAN C T ARE IN THE UPPER PORTION OF THE ARRAY AND ALL ELEMENTS C LESS THAN T ARE IN THE LOWER PORTION. THE UPPER AND LOWER C INDICES OF ONE OF THE PORTIONS ARE SAVED IN LOCAL ARRAYS, C AND THE PROCESS IS REPEATED ITERATIVELY ON THE OTHER C PORTION. WHEN A PORTION IS COMPLETELY SORTED, THE PROCESS C BEGINS AGAIN BY RETRIEVING THE INDICES BOUNDING ANOTHER C UNSORTED PORTION. C C INPUT PARAMETERS - N - LENGTH OF THE ARRAY X. C C X - VECTOR OF LENGTH N TO BE SORTED. C C IND - VECTOR OF LENGTH .GE. N. C C N AND X ARE NOT ALTERED BY THIS ROUTINE. C C OUTPUT PARAMETER - IND - SEQUENCE OF INDICES 1,...,N C PERMUTED IN THE SAME FASHION AS X C WOULD BE. THUS, THE ORDERING ON C X IS DEFINED BY Y(I) = X(IND(I)). C C INTRINSIC FUNCTIONS CALLED BY QSORTD - IFIX, FLOAT C C*********************************************************** C C NOTE -- IU AND IL MUST BE DIMENSIONED .GE. LOG(N) WHERE C LOG HAS BASE 2. C C*********************************************************** C INTEGER IU(21), IL(21) INTEGER M, I, J, K, L, IJ, IT, ITT, INDX REAL R DOUBLE PRECISION T C C LOCAL PARAMETERS - C C IU,IL = TEMPORARY STORAGE FOR THE UPPER AND LOWER C INDICES OF PORTIONS OF THE ARRAY X C M = INDEX FOR IU AND IL C I,J = LOWER AND UPPER INDICES OF A PORTION OF X C K,L = INDICES IN THE RANGE I,...,J C IJ = RANDOMLY CHOSEN INDEX BETWEEN I AND J C IT,ITT = TEMPORARY STORAGE FOR INTERCHANGES IN IND C INDX = TEMPORARY INDEX FOR X C R = PSEUDO RANDOM NUMBER FOR GENERATING IJ C T = CENTRAL ELEMENT OF X C IF (N .LE. 0) RETURN C C INITIALIZE IND, M, I, J, AND R C DO 1 I = 1,N 1 IND(I) = I M = 1 I = 1 J = N R = .375 C C TOP OF LOOP C 2 IF (I .GE. J) GO TO 10 IF (R .GT. .5898437) GO TO 3 R = R + .0390625 GO TO 4 3 R = R - .21875 C C INITIALIZE K C 4 K = I C C SELECT A CENTRAL ELEMENT OF X AND SAVE IT IN T C IJ = I + IFIX(R*FLOAT(J-I)) IT = IND(IJ) T = X(IT) C C IF THE FIRST ELEMENT OF THE ARRAY IS GREATER THAN T, C INTERCHANGE IT WITH T C INDX = IND(I) IF (X(INDX) .LE. T) GO TO 5 IND(IJ) = INDX IND(I) = IT IT = INDX T = X(IT) C C INITIALIZE L C 5 L = J C C IF THE LAST ELEMENT OF THE ARRAY IS LESS THAN T, C INTERCHANGE IT WITH T C INDX = IND(J) IF (X(INDX) .GE. T) GO TO 7 IND(IJ) = INDX IND(J) = IT IT = INDX T = X(IT) C C IF THE FIRST ELEMENT OF THE ARRAY IS GREATER THAN T, C INTERCHANGE IT WITH T C INDX = IND(I) IF (X(INDX) .LE. T) GO TO 7 IND(IJ) = INDX IND(I) = IT IT = INDX T = X(IT) GO TO 7 C C INTERCHANGE ELEMENTS K AND L C 6 ITT = IND(L) IND(L) = IND(K) IND(K) = ITT C C FIND AN ELEMENT IN THE UPPER PART OF THE ARRAY WHICH IS C NOT LARGER THAN T C 7 L = L - 1 INDX = IND(L) IF (X(INDX) .GT. T) GO TO 7 C C FIND AN ELEMENT IN THE LOWER PART OF THE ARRAY WHCIH IS C NOT SMALLER THAN T C 8 K = K + 1 INDX = IND(K) IF (X(INDX) .LT. T) GO TO 8 C C IF K .LE. L, INTERCHANGE ELEMENTS K AND L C IF (K .LE. L) GO TO 6 C C SAVE THE UPPER AND LOWER SUBSCRIPTS OF THE PORTION OF THE C ARRAY YET TO BE SORTED C IF (L-I .LE. J-K) GO TO 9 IL(M) = I IU(M) = L I = K M = M + 1 GO TO 11 C 9 IL(M) = K IU(M) = J J = L M = M + 1 GO TO 11 C C BEGIN AGAIN ON ANOTHER UNSORTED PORTION OF THE ARRAY C 10 M = M - 1 IF (M .EQ. 0) RETURN I = IL(M) J = IU(M) C 11 IF (J-I .GE. 11) GO TO 4 IF (I .EQ. 1) GO TO 2 I = I - 1 C C SORT ELEMENTS I+1,...,J. NOTE THAT 1 .LE. I .LT. J AND C J-I .LT. 11. C 12 I = I + 1 IF (I .EQ. J) GO TO 10 INDX = IND(I+1) T = X(INDX) IT = INDX INDX = IND(I) IF (X(INDX) .LE. T) GO TO 12 K = I C 13 IND(K+1) = IND(K) K = K - 1 INDX = IND(K) IF (T .LT. X(INDX)) GO TO 13 IND(K+1) = IT GO TO 12 END SUBROUTINE IORDER (A, IP, N) INTEGER N, A(N), IP(N) C C*********************************************************** C C ROBERT RENKA C OAK RIDGE NATL. LAB. C C THIS ROUTINE APPLIES A SET OF PERMUTATIONS TO A VECTOR. C C INPUT PARAMETERS - N - LENGTH OF A AND IP. C C IP - VECTOR CONTAINING THE SEQUENCE OF C INTEGERS 1,...,N PERMUTED IN THE C SAME FASHION THAT A IS TO BE PER- C MUTED. C C A - VECTOR TO BE PERMUTED. C C N AND IP ARE NOT ALTERED BY THIS ROUTINE. C C OUTPUT PARAMETER - A - REORDERED VECTOR REFLECTING THE C PERMUTATIONS DEFINED BY IP. C C*********************************************************** C INTEGER NN, K, J, IPJ, TEMP C C LOCAL PARAMETERS - C C NN = LOCAL COPY OF N C K = INDEX FOR IP AND FOR THE FIRST ELEMENT OF A IN A C PERMUTATION C J = INDEX FOR IP AND A, J .GE. K C IPJ = IP(J) C TEMP = TEMPORARY STORAGE FOR A(K) C NN = N IF (NN .LT. 2) RETURN K = 1 C C LOOP ON PERMUTATIONS C 1 J = K TEMP = A(K) C C APPLY PERMUTATION TO A. IP(J) IS MARKED (MADE NEGATIVE) C AS BEING INCLUDED IN THE PERMUTATION. C 2 IPJ = IP(J) IP(J) = -IPJ IF (IPJ .EQ. K) GO TO 3 A(J) = A(IPJ) J = IPJ GO TO 2 3 A(J) = TEMP C C SEARCH FOR AN UNMARKED ELEMENT OF IP C 4 K = K + 1 IF (K .GT. NN) GO TO 5 IF (IP(K) .GT. 0) GO TO 1 GO TO 4 C C ALL PERMUTATIONS HAVE BEEN APPLIED. UNMARK IP. C 5 DO 6 K = 1,NN 6 IP(K) = -IP(K) RETURN END SUBROUTINE RORDER (A, IP, N) INTEGER N, IP(N) REAL A(N) C C*********************************************************** C C ROBERT RENKA C OAK RIDGE NATL. LAB. C C THIS ROUTINE APPLIES A SET OF PERMUTATIONS TO A VECTOR. C C INPUT PARAMETERS - N - LENGTH OF A AND IP. C C IP - VECTOR CONTAINING THE SEQUENCE OF C INTEGERS 1,...,N PERMUTED IN THE C SAME FASHION THAT A IS TO BE PER- C MUTED. C C A - VECTOR TO BE PERMUTED. C C N AND IP ARE NOT ALTERED BY THIS ROUTINE. C C OUTPUT PARAMETER - A - REORDERED VECTOR REFLECTING THE C PERMUTATIONS DEFINED BY IP. C C*********************************************************** C INTEGER NN, K, J, IPJ REAL TEMP C C LOCAL PARAMETERS - C C NN = LOCAL COPY OF N C K = INDEX FOR IP AND FOR THE FIRST ELEMENT OF A IN A C PERMUTATION C J = INDEX FOR IP AND A, J .GE. K C IPJ = IP(J) C TEMP = TEMPORARY STORAGE FOR A(K) C NN = N IF (NN .LT. 2) RETURN K = 1 C C LOOP ON PERMUTATIONS C 1 J = K TEMP = A(K) C C APPLY PERMUTATION TO A. IP(J) IS MARKED (MADE NEGATIVE) C AS BEING INCLUDED IN THE PERMUTATION. C 2 IPJ = IP(J) IP(J) = -IPJ IF (IPJ .EQ. K) GO TO 3 A(J) = A(IPJ) J = IPJ GO TO 2 3 A(J) = TEMP C C SEARCH FOR AN UNMARKED ELEMENT OF IP C 4 K = K + 1 IF (K .GT. NN) GO TO 5 IF (IP(K) .GT. 0) GO TO 1 GO TO 4 C C ALL PERMUTATIONS HAVE BEEN APPLIED. UNMARK IP. C 5 DO 6 K = 1,NN 6 IP(K) = -IP(K) RETURN END SUBROUTINE DORDER (A, IP, N) INTEGER N, IP(N) DOUBLE PRECISION A(N) C C*********************************************************** C C ROBERT RENKA C OAK RIDGE NATL. LAB. C C THIS ROUTINE APPLIES A SET OF PERMUTATIONS TO A VECTOR. C C INPUT PARAMETERS - N - LENGTH OF A AND IP. C C IP - VECTOR CONTAINING THE SEQUENCE OF C INTEGERS 1,...,N PERMUTED IN THE C SAME FASHION THAT A IS TO BE PER- C MUTED. C C A - VECTOR TO BE PERMUTED. C C N AND IP ARE NOT ALTERED BY THIS ROUTINE. C C OUTPUT PARAMETER - A - REORDERED VECTOR REFLECTING THE C PERMUTATIONS DEFINED BY IP. C C*********************************************************** C INTEGER NN, K, J, IPJ DOUBLE PRECISION TEMP C C LOCAL PARAMETERS - C C NN = LOCAL COPY OF N C K = INDEX FOR IP AND FOR THE FIRST ELEMENT OF A IN A C PERMUTATION C J = INDEX FOR IP AND A, J .GE. K C IPJ = IP(J) C TEMP = TEMPORARY STORAGE FOR A(K) C NN = N IF (NN .LT. 2) RETURN K = 1 C C LOOP ON PERMUTATIONS C 1 J = K TEMP = A(K) C C APPLY PERMUTATION TO A. IP(J) IS MARKED (MADE NEGATIVE) C AS BEING INCLUDED IN THE PERMUTATION. C 2 IPJ = IP(J) IP(J) = -IPJ IF (IPJ .EQ. K) GO TO 3 A(J) = A(IPJ) J = IPJ GO TO 2 3 A(J) = TEMP C C SEARCH FOR AN UNMARKED ELEMENT OF IP C 4 K = K + 1 IF (K .GT. NN) GO TO 5 IF (IP(K) .GT. 0) GO TO 1 GO TO 4 C C ALL PERMUTATIONS HAVE BEEN APPLIED. UNMARK IP. C 5 DO 6 K = 1,NN 6 IP(K) = -IP(K) RETURN END REAL FUNCTION CBRT (X) C----------------------------------------------------------------------- C CUBE ROOT OF A REAL NUMBER C----------------------------------------------------------------------- IF (X) 30, 10, 20 10 CBRT = 0.0 RETURN 20 R = ALOG(X)/3.0 CBRT = EXP(R) RETURN 30 R = ALOG(-X)/3.0 CBRT = -EXP(R) RETURN END DOUBLE PRECISION FUNCTION DCBRT (X) C----------------------------------------------------------------------- C CUBE ROOT OF A REAL NUMBER C----------------------------------------------------------------------- DOUBLE PRECISION X, R C IF (X) 30, 10, 20 10 DCBRT = 0.D0 RETURN 20 R = DLOG(X)/3.D0 DCBRT = DEXP(R) RETURN 30 R = DLOG(-X)/3.D0 DCBRT = -DEXP(R) RETURN END FUNCTION ARTNQ(Y,X) IF (X) 1,2,5 1 ARTNQ=ATAN(Y/X)+3.1415926535898 RETURN 2 IF (Y) 3,8,4 3 ARTNQ=4.7123889803847 RETURN 4 ARTNQ=1.5707963267949 RETURN 5 IF (Y) 6,8,7 6 ARTNQ=ATAN(Y/X)+6.2831853071795 RETURN 7 ARTNQ=ATAN(Y/X) RETURN 8 ARTNQ=0. RETURN END DOUBLE PRECISION FUNCTION DARTNQ(Y,X) DOUBLE PRECISION X,Y IF (X) 1,2,5 1 DARTNQ=DATAN(Y/X)+3.14159265358979323846264338328D0 RETURN 2 IF (Y) 3,8,4 3 DARTNQ=4.71238898038468985769396507492D0 RETURN 4 DARTNQ=1.57079632679489661923132169164D0 RETURN 5 IF (Y) 6,8,7 6 DARTNQ=DATAN(Y/X)+6.28318530717958647692528676656D0 RETURN 7 DARTNQ=DATAN(Y/X) RETURN 8 DARTNQ=0.D0 RETURN END REAL FUNCTION CPABS(X, Y) C -------------------------------------- C EVALUATION OF SQRT(X*X + Y*Y) C -------------------------------------- IF (ABS(X) .LE. ABS(Y)) GO TO 10 A = Y/X CPABS = ABS(X)*SQRT(1.0 + A*A) RETURN 10 IF (Y .EQ. 0.0) GO TO 20 A = X/Y CPABS = ABS(Y)*SQRT(1.0 + A*A) RETURN 20 CPABS = 0.0 RETURN END DOUBLE PRECISION FUNCTION DCPABS(X, Y) DOUBLE PRECISION X, Y C -------------------------------------- C EVALUATION OF SQRT(X*X + Y*Y) C -------------------------------------- DOUBLE PRECISION A C IF (DABS(X) .LE. DABS(Y)) GO TO 10 A = Y/X DCPABS = DABS(X)*DSQRT(1.D0 + A*A) RETURN 10 IF (Y .EQ. 0.D0) GO TO 20 A = X/Y DCPABS = DABS(Y)*DSQRT(1.D0 + A*A) RETURN 20 DCPABS = 0.D0 RETURN END SUBROUTINE CREC (X, Y, U, V) C----------------------------------------------------------------------- C COMPLEX RECIPROCAL U + I*V = 1/(X + I*Y) C----------------------------------------------------------------------- IF (ABS(X) .GT. ABS(Y)) GO TO 10 T = X/Y D = Y + T*X U = T/D V = -1.0/D RETURN 10 T = Y/X D = X + T*Y U = 1.0/D V = -T/D RETURN END SUBROUTINE DCREC (X, Y, U, V) C----------------------------------------------------------------------- C COMPLEX RECIPROCAL U + I*V = 1/(X + I*Y) C----------------------------------------------------------------------- DOUBLE PRECISION X, Y, U, V DOUBLE PRECISION D, T C IF (DABS(X) .GT. DABS(Y)) GO TO 10 T = X/Y D = Y + T*X U = T/D V = -1.D0/D RETURN 10 T = Y/X D = X + T*Y U = 1.D0/D V = -T/D RETURN END COMPLEX FUNCTION CDIV (A, B) C----------------------------------------------------------------------- C COMPLEX DIVISION A/B WHERE B IS NONZERO C----------------------------------------------------------------------- COMPLEX A, B C AR = REAL(A) AI = AIMAG(A) BR = REAL(B) BI = AIMAG(B) C IF (ABS(BR) .LT. ABS(BI)) GO TO 10 T = BI/BR D = BR + T*BI U = (AR + AI*T)/D V = (AI - AR*T)/D CDIV = CMPLX(U,V) RETURN 10 T = BR/BI D = BI + T*BR U = (AR*T + AI)/D V = (AI*T - AR)/D CDIV = CMPLX(U,V) RETURN END SUBROUTINE CDIVID (AR,AI,BR,BI,CR,CI) C----------------------------------------------------------------------- C DOUBLE PRECISION COMPLEX DIVISION C = A/B AVOIDING OVERFLOW C----------------------------------------------------------------------- DOUBLE PRECISION AR, AI, BR, BI, CR, CI DOUBLE PRECISION D, T, U, V DOUBLE PRECISION DPMPAR C IF (DABS(BR) .LE. DABS(BI)) GO TO 10 T = BI/BR D = BR + T*BI U = (AR + AI*T)/D V = (AI - AR*T)/D CR = U CI = V RETURN C 10 IF (BI .EQ. 0.D0) GO TO 20 T = BR/BI D = BI + T*BR U = (AR*T + AI)/D V = (AI*T - AR)/D CR = U CI = V RETURN C C DIVISION BY ZERO. C = INFINITY C 20 CR = DPMPAR(3) CI = CR RETURN END SUBROUTINE DCSQRT (Z, W) DOUBLE PRECISION Z(2), W(2) C ---------------------------------------------------------------------- C W = SQRT(Z) FOR THE DOUBLE PRECISION COMPLEX NUMBER Z C C ----------- C C Z AND W ARE INTERPRETED AS DOUBLE PRECISION COMPLEX NUMBERS. C IT IS ASSUMED THAT Z(1) AND Z(2) ARE THE REAL AND IMAGINARY C PARTS OF THE COMPLEX NUMBER Z, AND THAT W(1) AND W(2) ARE C THE REAL AND IMAGINARY PARTS OF W. C ---------------------------------------------------------------------- DOUBLE PRECISION X, Y, R DOUBLE PRECISION DCPABS C X = Z(1) Y = Z(2) IF (X) 30,10,20 C 10 IF (Y .NE. 0.D0) GO TO 11 W(1) = 0.D0 W(2) = 0.D0 RETURN 11 W(1) = DSQRT(0.5D0*DABS(Y)) W(2) = DSIGN(W(1),Y) RETURN C 20 IF (Y .NE. 0.D0) GO TO 21 W(1) = DSQRT(X) W(2) = 0.D0 RETURN 21 R = DCPABS(X,Y) W(1) = DSQRT(0.5D0*(R + X)) W(2) = 0.5D0*Y/W(1) RETURN C 30 IF (Y .NE. 0.D0) GO TO 31 W(1) = 0.D0 W(2) = DSQRT(DABS(X)) RETURN 31 R = DCPABS(X,Y) W(2) = DSQRT(0.5D0*(R - X)) W(2) = DSIGN(W(2),Y) W(1) = 0.5D0*Y/W(2) RETURN END SUBROUTINE POCA(R,A,X,Y) X=R*COS(A) Y=R*SIN(A) RETURN END SUBROUTINE CAPO(X,Y,R,THETA) IF (ABS(X).LE.ABS(Y)) GO TO 10 A=Y/X R=ABS(X)*SQRT(1.0+A*A) THETA=ATAN2(Y,X) RETURN 10 IF (Y.EQ.0.) GO TO 20 A=X/Y R=ABS(Y)*SQRT(1.0+A*A) THETA=ATAN2(Y,X) RETURN 20 R=0.0 THETA=0.0 RETURN END SUBROUTINE ROTA(X1,Y1,A,X2,Y2) SINA=SIN(A) COSA=COS(A) X2= X1*COSA+Y1*SINA Y2=-X1*SINA+Y1*COSA RETURN END SUBROUTINE SROTG(SA,SB,SC,SS) C C DESIGNED BY C.L.LAWSON, JPL, 1977 SEPT 08 C C C CONSTRUCT THE GIVENS TRANSFORMATION C C ( SC SS ) C G = ( ) , SC**2 + SS**2 = 1 , C (-SS SC ) C C WHICH ZEROS THE SECOND ENTRY OF THE 2-VECTOR (SA,SB)**T . C C THE QUANTITY R = (+/-)SQRT(SA**2 + SB**2) OVERWRITES SA IN C STORAGE. THE VALUE OF SB IS OVERWRITTEN BY A VALUE Z WHICH C ALLOWS SC AND SS TO BE RECOVERED BY THE FOLLOWING ALGORITHM: C IF Z=1 SET SC=0. AND SS=1. C IF ABS(Z) .LT. 1 SET SC=SQRT(1-Z**2) AND SS=Z C IF ABS(Z) .GT. 1 SET SC=1/Z AND SS=SQRT(1-SC**2) C C NORMALLY, THE SUBPROGRAM SROT(N,SX,INCX,SY,INCY,SC,SS) WILL C NEXT BE CALLED TO APPLY THE TRANSFORMATION TO A 2 BY N MATRIX. C C ------------------------------------------------------------------ C IF (ABS(SA) .LE. ABS(SB)) GO TO 10 C C *** HERE ABS(SA) .GT. ABS(SB) *** C U = SA + SA V = SB / U C C NOTE THAT U AND R HAVE THE SIGN OF SA C R = SQRT(.25 + V**2) * U C C NOTE THAT SC IS POSITIVE C SC = SA / R SS = V * (SC + SC) SB = SS SA = R RETURN C C *** HERE ABS(SA) .LE. ABS(SB) *** C 10 IF (SB .EQ. 0.) GO TO 20 U = SB + SB V = SA / U C C NOTE THAT U AND R HAVE THE SIGN OF SB C (R IS IMMEDIATELY STORED IN SA) C SA = SQRT(.25 + V**2) * U C C NOTE THAT SS IS POSITIVE C SS = SB / SA SC = V * (SS + SS) IF (SC .EQ. 0.) GO TO 15 SB = 1. / SC RETURN 15 SB = 1. RETURN C C *** HERE SA = SB = 0. *** C 20 SC = 1. SS = 0. RETURN C END SUBROUTINE DROTG(DA,DB,DC,DS) C C DESIGNED BY C.L.LAWSON, JPL, 1977 SEPT 08 C C C CONSTRUCT THE GIVENS TRANSFORMATION C C ( DC DS ) C G = ( ) , DC**2 + DS**2 = 1 , C (-DS DC ) C C WHICH ZEROS THE SECOND ENTRY OF THE 2-VECTOR (DA,DB)**T . C C THE QUANTITY R = (+/-)DSQRT(DA**2 + DB**2) OVERWRITES DA IN C STORAGE. THE VALUE OF DB IS OVERWRITTEN BY A VALUE Z WHICH C ALLOWS DC AND DS TO BE RECOVERED BY THE FOLLOWING ALGORITHM: C IF Z=1 SET DC=0.D0 AND DS=1.D0 C IF DABS(Z) .LT. 1 SET DC=DSQRT(1-Z**2) AND DS=Z C IF DABS(Z) .GT. 1 SET DC=1/Z AND DS=DSQRT(1-DC**2) C C NORMALLY, THE SUBPROGRAM DROT(N,DX,INCX,DY,INCY,DC,DS) WILL C NEXT BE CALLED TO APPLY THE TRANSFORMATION TO A 2 BY N MATRIX. C C ------------------------------------------------------------------ C DOUBLE PRECISION DA, DB, DC, DS, U, V, R IF (DABS(DA) .LE. DABS(DB)) GO TO 10 C C *** HERE DABS(DA) .GT. DABS(DB) *** C U = DA + DA V = DB / U C C NOTE THAT U AND R HAVE THE SIGN OF DA C R = DSQRT(.25D0 + V**2) * U C C NOTE THAT DC IS POSITIVE C DC = DA / R DS = V * (DC + DC) DB = DS DA = R RETURN C C *** HERE DABS(DA) .LE. DABS(DB) *** C 10 IF (DB .EQ. 0.D0) GO TO 20 U = DB + DB V = DA / U C C NOTE THAT U AND R HAVE THE SIGN OF DB C (R IS IMMEDIATELY STORED IN DA) C DA = DSQRT(.25D0 + V**2) * U C C NOTE THAT DS IS POSITIVE C DS = DB / DA DC = V * (DS + DS) IF (DC .EQ. 0.D0) GO TO 15 DB = 1.D0 / DC RETURN 15 DB = 1.D0 RETURN C C *** HERE DA = DB = 0.D0 *** C 20 DC = 1.D0 DS = 0.D0 RETURN C END SUBROUTINE ROT3 (A, THETA) DIMENSION A(3,3), THETA(3) DATA PIHALF/1.5707963267949/ C -------------------- IF (ABS(A(1,1)) .GT. ABS(A(2,1))) GO TO 10 IF (A(2,1) .NE. 0.0) GO TO 11 C C CASE WHEN A(1,1) = A(2,1) = 0 C THETA(3) = 0.0 THETA(2) = SIGN(PIHALF,A(3,1)) U = A(2,2) V = A(1,2) IF (A(3,1) .GT. 0.0) V = -V THETA(1) = ATAN2(V,U) RETURN C C COMPUTATION OF R = SQRT(A(1,1)**2 + A(2,1)**2) C 10 T = A(2,1)/A(1,1) R = ABS(A(1,1))*SQRT(1.0 + T*T) GO TO 20 11 T = A(1,1)/A(2,1) R = ABS(A(2,1))*SQRT(1.0 + T*T) C C EVALUATION OF THE ANGLES C 20 THETA(3) = ATAN2(A(2,1),A(1,1)) THETA(2) = ATAN2(A(3,1),R) U = DBLE(A(1,1))*DBLE(A(2,2)) - DBLE(A(1,2))*DBLE(A(2,1)) IF (ABS(THETA(2)) .GT. 0.8) GO TO 21 U = U/R V = A(3,2)/COS(THETA(2)) GO TO 22 21 V = DBLE(A(1,1))*DBLE(A(1,2)) + DBLE(A(2,1))*DBLE(A(2,2)) V = -V/SIN(THETA(2)) 22 THETA(1) = ATAN2(V,U) RETURN END SUBROUTINE CONSTR (XK,YK,ZK, CX,SX,CY,SY) REAL XK, YK, ZK, CX, SX, CY, SY C C*********************************************************** C C ROBERT RENKA C OAK RIDGE NATL. LAB. C C THIS SUBROUTINE CONSTRUCTS THE ELEMENTS OF A 3 BY 3 C ORTHOGONAL MATRIX R WHICH ROTATES A POINT (XK,YK,ZK) ON C THE UNIT SPHERE TO THE NORTH POLE, I.E. C C (XK) (CY 0 -SY) (1 0 0) (XK) (0) C R * (YK) = ( 0 1 0) * (0 CX -SX) * (YK) = (0) C (ZK) (SY 0 CY) (0 SX CX) (ZK) (1) C C INPUT PARAMETERS - XK,YK,ZK - COMPONENTS OF A UNIT VECTOR C TO BE ROTATED TO (0,0,1). C C INPUT PARAMETERS ARE NOT ALTERED BY THIS ROUTINE. C C OUTPUT PARAMETERS - CX,SX,CY,SY - ELEMENTS OF R -- CX,SX C DEFINE A ROTATION ABOUT C THE X-AXIS AND CY,SY DE- C FINE A ROTATION ABOUT C THE Y-AXIS. C C INTRINSIC FUNCTION CALLED BY CONSTR - SQRT C C*********************************************************** C CY = SQRT(YK*YK + ZK*ZK) SY = XK IF (CY .EQ. 0.) GO TO 1 CX = ZK/CY SX = YK/CY RETURN C C (XK,YK,ZK) LIES ON THE X-AXIS C 1 CX = 1. SX = 0. RETURN END REAL FUNCTION ANG (N, X, Y) C----------------------------------------------------------------------- C COMPUTATION OF THE ANGLE BETWEEN TWO VECTORS C----------------------------------------------------------------------- REAL X(N), Y(N) C IF (N .LT. 2) GO TO 30 RX = SNRM2(N, X, 1) IF (RX .EQ. 0.0) GO TO 30 RY = SNRM2(N, Y, 1) IF (RY .EQ. 0.0) GO TO 30 C D = 0.0 DO 10 I = 1,N D = D + (X(I)/RX - Y(I)/RY)**2 10 CONTINUE IF (D .GT. 3.0) GO TO 20 ANG = ACOS(0.5 + (0.5 - 0.5*D)) RETURN C 20 D = 0.0 DO 21 I = 1,N D = D + (X(I)/RX + Y(I)/RY)**2 21 CONTINUE ANG = ACOS((0.5*D - 0.5) - 0.5) RETURN C C ERROR RETURN C 30 ANG = -1.0 RETURN END REAL FUNCTION SIN0 (X) C----------------------------------------------------------------------- C COMPUTATION OF SIN(X*PI/2) FOR ABS(X) .LE. 0.5 C----------------------------------------------------------------------- DATA A0 /.157079632679490E+01/, A1 /-.645964097506244E+00/, * A2 /.796926262460396E-01/, A3 /-.468175413228242E-02/, * A4 /.160441150291651E-03/, A5 /-.359864175444606E-05/, * A6 /.563372101191893E-07/ C------------------------ T = X*X SIN0 = ((((((A6*T + A5)*T + A4)*T + A3)*T + A2)*T * + A1)*T + A0)*X RETURN END REAL FUNCTION COS0 (X) C----------------------------------------------------------------------- C COMPUTATION OF COS(X*PI/2) FOR ABS(X) .LE. 0.5 C----------------------------------------------------------------------- DATA A1 /-.123370055013615E+01/, A2 /.253669507899753E+00/, * A3 /-.208634807330586E-01/, A4 /.919259935580283E-03/, * A5 /-.252000841382533E-04/, A6 /.465461768260405E-06/ C------------------------ T = X*X COS0 = (((((A6*T + A5)*T + A4)*T + A3)*T + A2)*T + A1)*T + 1.0 RETURN END REAL FUNCTION SIN1 (X) C----------------------------------------------------------------------- C EVALUATION OF SIN(X*PI) C----------------------------------------------------------------------- DATA A0 /.314159265358979E+01/, A1 /-.516771278004995E+01/, * A2 /.255016403987327E+01/, A3 /-.599264528932149E+00/, * A4 /.821458689493251E-01/, A5 /-.737001831310553E-02/, * A6 /.461514425296398E-03/ DATA B1 /-.493480220054460E+01/, B2 /.405871212639605E+01/, * B3 /-.133526276691575E+01/, B4 /.235330543508553E+00/, * B5 /-.258048861575714E-01/, B6 /.190653140279462E-02/ C------------------------ C C ****** MAX IS A MACHINE DEPENDENT CONSTANT. MAX IS THE C LARGEST POSITIVE INTEGER THAT MAY BE USED. C MAX = IPMPAR(3) C C------------------------ A = ABS(X) IF (A .LT. FLOAT(MAX)) GO TO 10 SIN1 = 0.0 RETURN C 10 N = A A = A - FLOAT(N) IF (A .GT. 0.75) GO TO 20 IF (A .LT. 0.25) GO TO 21 C C 0.25 .LE. A .LE. 0.75 C A = 0.25 + (0.25 - A) T = A*A SIN1 = ((((((B6*T + B5)*T + B4)*T + B3)*T + B2)*T * + B1)*T + 0.5) + 0.5 GO TO 30 C C A .LT. 0.25 OR A .GT. 0.75 C 20 A = 0.25 + (0.75 - A) 21 T = A*A SIN1 = ((((((A6*T + A5)*T + A4)*T + A3)*T + A2)*T * + A1)*T + A0)*A C C TERMINATION C 30 IF (X .LT. 0.0) SIN1 = - SIN1 IF (MOD(N,2) .NE. 0) SIN1 = - SIN1 RETURN END REAL FUNCTION COS1 (X) C----------------------------------------------------------------------- C EVALUATION OF COS(X*PI) C----------------------------------------------------------------------- DATA A0 /.314159265358979E+01/, A1 /-.516771278004995E+01/, * A2 /.255016403987327E+01/, A3 /-.599264528932149E+00/, * A4 /.821458689493251E-01/, A5 /-.737001831310553E-02/, * A6 /.461514425296398E-03/ DATA B1 /-.493480220054460E+01/, B2 /.405871212639605E+01/, * B3 /-.133526276691575E+01/, B4 /.235330543508553E+00/, * B5 /-.258048861575714E-01/, B6 /.190653140279462E-02/ C------------------------ C C ****** MAX IS A MACHINE DEPENDENT CONSTANT. MAX IS THE C LARGEST POSITIVE INTEGER THAT MAY BE USED. C MAX = IPMPAR(3) C C------------------------ A = ABS(X) IF (A .LT. FLOAT(MAX)) GO TO 10 COS1 = 1.0 RETURN C 10 N = A A = A - FLOAT(N) IF (A .GT. 0.75) GO TO 20 IF (A .LT. 0.25) GO TO 21 C C 0.25 .LE. A .LE. 0.75 C A = 0.25 + (0.25 - A) T = A*A COS1 = ((((((A6*T + A5)*T + A4)*T + A3)*T + A2)*T * + A1)*T + A0)*A GO TO 30 C C A .LT. 0.25 OR A .GT. 0.75 C 20 A = 0.25 + (0.75 - A) N = N - 1 21 T = A*A COS1 = ((((((B6*T + B5)*T + B4)*T + B3)*T + B2)*T * + B1)*T + 0.5) + 0.5 C C TERMINATION C 30 IF (MOD(N,2) .NE. 0) COS1 = - COS1 RETURN END DOUBLE PRECISION FUNCTION DSIN1 (X) C----------------------------------------------------------------------- C C DOUBLE PRECISION EVALUATION OF SIN(PI*X) C C -------------- C C THE EXPANSION FOR SIN(PI*A) (ABS(A) .LE. PI/4) USING A1,...,A13 C IS ACCURATE TO WITHIN 2 UNITS OF THE 40-TH SIGNIFICANT DIGIT, AND C THE EXPANSION FOR COS(PI*A) (ABS(A) .LE. PI/4) USING B1,...,B13 C IS ACCURATE TO WITHIN 4 UNITS OF THE 40-TH SIGNIFICANT DIGIT. C C----------------------------------------------------------------------- DOUBLE PRECISION X DOUBLE PRECISION A, PI, T, W DOUBLE PRECISION A1, A2, A3, A4, A5, A6, A7, A8, A9, A10, * A11, A12, A13 DOUBLE PRECISION B1, B2, B3, B4, B5, B6, B7, B8, B9, B10, * B11, B12, B13 C------------------------ DATA PI /3.141592653589793238462643383279502884197D+00/ C------------------------ DATA A1 /-.1028083791780141522795259479153765743002D+00/, * A2 / .3170868848763100170457042079710451905600D-02/, * A3 /-.4657026956105571623449026167864697920000D-04/, * A4 / .3989844942879455643410226655783424000000D-06/, * A5 /-.2237397227721999776371894030796800000000D-08/, * A6 / .8847045483056962709715066675200000000000D-11/, * A7 /-.2598715447506450292885585920000000000000D-13/, * A8 / .5893449774331011070033920000000000000000D-16/, * A9 /-.1062975472045522550784000000000000000000D-18/, * A10 / .1561182648301780992000000000000000000000D-21/, * A11 /-.1903193516670976000000000000000000000000D-24/, * A12 / .1956617650176000000000000000000000000000D-27/, * A13 /-.1711276032000000000000000000000000000000D-30/ C------------------------ DATA B1 /-.3084251375340424568385778437461297229882D+00/, * B2 / .1585434424381550085228521039855226435920D-01/, * B3 /-.3259918869273900136414318317506279360000D-03/, * B4 / .3590860448591510079069203991239232000000D-05/, * B5 /-.2461136950494199754009084061808640000000D-07/, * B6 / .1150115912797405152263195572224000000000D-09/, * B7 /-.3898073171259675439899172864000000000000D-12/, * B8 / .1001886461636271969091584000000000000000D-14/, * B9 /-.2019653396886572027084800000000000000000D-17/, * B10 / .3278483561466560512000000000000000000000D-20/, * B11 /-.4377345082051788800000000000000000000000D-23/, * B12 / .4891532381388800000000000000000000000000D-26/, * B13 /-.4617089843200000000000000000000000000000D-29/ C------------------------ C C ****** MAX IS A MACHINE DEPENDENT CONSTANT. MAX IS THE C LARGEST POSITIVE INTEGER THAT MAY BE USED. C MAX = IPMPAR(3) C C------------------------ A = DABS(X) T = MAX IF (A .LT. T) GO TO 10 DSIN1 = 0.D0 RETURN C 10 N = A T = N A = A - T IF (A .GT. 0.75D0) GO TO 20 IF (A .LT. 0.25D0) GO TO 21 C C 0.25 .LE. A .LE. 0.75 C A = 0.25D0 + (0.25D0 - A) T = 16.D0*A*A DSIN1 = (((((((((((((B13*T + B12)*T + B11)*T + B10)*T + B9)*T + * B8)*T + B7)*T + B6)*T + B5)*T + B4)*T + B3)*T + * B2)*T + B1)*T + 0.5D0) + 0.5D0 GO TO 30 C C A .LT. 0.25 OR A .GT. 0.75 C 20 A = 0.25D0 + (0.75D0 - A) 21 T = 16.D0*A*A W = (((((((((((((A13*T + A12)*T + A11)*T + A10)*T + A9)*T + * A8)*T + A7)*T + A6)*T + A5)*T + A4)*T + A3)*T + * A2)*T + A1)*T + 0.5D0) + 0.5D0 DSIN1 = PI*A*W C C TERMINATION C 30 IF (X .LT. 0.0) DSIN1 = - DSIN1 IF (MOD(N,2) .NE. 0) DSIN1 = - DSIN1 RETURN END DOUBLE PRECISION FUNCTION DCOS1 (X) C----------------------------------------------------------------------- C C DOUBLE PRECISION EVALUATION OF COS(PI*X) C C -------------- C C THE EXPANSION FOR SIN(PI*A) (ABS(A) .LE. PI/4) USING A1,...,A13 C IS ACCURATE TO WITHIN 2 UNITS OF THE 40-TH SIGNIFICANT DIGIT, AND C THE EXPANSION FOR COS(PI*A) (ABS(A) .LE. PI/4) USING B1,...,B13 C IS ACCURATE TO WITHIN 4 UNITS OF THE 40-TH SIGNIFICANT DIGIT. C C----------------------------------------------------------------------- DOUBLE PRECISION X DOUBLE PRECISION A, PI, T, W DOUBLE PRECISION A1, A2, A3, A4, A5, A6, A7, A8, A9, A10, * A11, A12, A13 DOUBLE PRECISION B1, B2, B3, B4, B5, B6, B7, B8, B9, B10, * B11, B12, B13 C------------------------ DATA PI /3.141592653589793238462643383279502884197D+00/ C------------------------ DATA A1 /-.1028083791780141522795259479153765743002D+00/, * A2 / .3170868848763100170457042079710451905600D-02/, * A3 /-.4657026956105571623449026167864697920000D-04/, * A4 / .3989844942879455643410226655783424000000D-06/, * A5 /-.2237397227721999776371894030796800000000D-08/, * A6 / .8847045483056962709715066675200000000000D-11/, * A7 /-.2598715447506450292885585920000000000000D-13/, * A8 / .5893449774331011070033920000000000000000D-16/, * A9 /-.1062975472045522550784000000000000000000D-18/, * A10 / .1561182648301780992000000000000000000000D-21/, * A11 /-.1903193516670976000000000000000000000000D-24/, * A12 / .1956617650176000000000000000000000000000D-27/, * A13 /-.1711276032000000000000000000000000000000D-30/ C------------------------ DATA B1 /-.3084251375340424568385778437461297229882D+00/, * B2 / .1585434424381550085228521039855226435920D-01/, * B3 /-.3259918869273900136414318317506279360000D-03/, * B4 / .3590860448591510079069203991239232000000D-05/, * B5 /-.2461136950494199754009084061808640000000D-07/, * B6 / .1150115912797405152263195572224000000000D-09/, * B7 /-.3898073171259675439899172864000000000000D-12/, * B8 / .1001886461636271969091584000000000000000D-14/, * B9 /-.2019653396886572027084800000000000000000D-17/, * B10 / .3278483561466560512000000000000000000000D-20/, * B11 /-.4377345082051788800000000000000000000000D-23/, * B12 / .4891532381388800000000000000000000000000D-26/, * B13 /-.4617089843200000000000000000000000000000D-29/ C------------------------ C C ****** MAX IS A MACHINE DEPENDENT CONSTANT. MAX IS THE C LARGEST POSITIVE INTEGER THAT MAY BE USED. C MAX = IPMPAR(3) C C------------------------ A = DABS(X) T = MAX IF (A .LT. T) GO TO 10 DCOS1 = 1.D0 RETURN C 10 N = A T = N A = A - T IF (A .GT. 0.75D0) GO TO 20 IF (A .LT. 0.25D0) GO TO 21 C C 0.25 .LE. A .LE. 0.75 C A = 0.25D0 + (0.25D0 - A) T = 16.D0*A*A W = (((((((((((((A13*T + A12)*T + A11)*T + A10)*T + A9)*T + * A8)*T + A7)*T + A6)*T + A5)*T + A4)*T + A3)*T + * A2)*T + A1)*T + 0.5D0) + 0.5D0 DCOS1 = PI*A*W GO TO 30 C C A .LT. 0.25 OR A .GT. 0.75 C 20 A = 0.25D0 + (0.75D0 - A) N = N - 1 21 T = 16.D0*A*A DCOS1 = (((((((((((((B13*T + B12)*T + B11)*T + B10)*T + B9)*T + * B8)*T + B7)*T + B6)*T + B5)*T + B4)*T + B3)*T + * B2)*T + B1)*T + 0.5D0) + 0.5D0 C C TERMINATION C 30 IF (MOD(N,2) .NE. 0) DCOS1 = - DCOS1 RETURN END SUBROUTINE SNHCSH (SINHM,COSHM,X,ISW) C INTEGER ISW REAL SINHM,COSHM,X,CUT(5) C C FROM THE SPLINE UNDER TENSION PACKAGE C CODED BY A. K. CLINE AND R. J. RENKA C DEPARTMENT OF COMPUTER SCIENCES C UNIVERSITY OF TEXAS AT AUSTIN C MODIFIED BY A.H. MORRIS (NSWC/DL) C C THIS SUBROUTINE RETURNS APPROXIMATIONS TO C SINHM(X) = SINH(X)-X C COSHM(X) = COSH(X)-1 C AND C COSHMM(X) = COSH(X)-1-X*X/2 C C ON INPUT-- C C X CONTAINS THE VALUE OF THE INDEPENDENT VARIABLE. C C ISW INDICATES THE FUNCTION DESIRED C = -1 IF ONLY SINHM IS DESIRED, C = 0 IF BOTH SINHM AND COSHM ARE DESIRED, C = 1 IF ONLY COSHM IS DESIRED, C = 2 IF ONLY COSHMM IS DESIRED, C = 3 IF BOTH SINHM AND COSHMM ARE DESIRED. C C ON OUTPUT-- C C SINHM CONTAINS THE VALUE OF SINHM(X) IF ISW .LE. 0 OR C ISW .EQ. 3 (SINHM IS UNALTERED IF ISW .EQ.1 OR ISW .EQ. C 2). C C COSHM CONTAINS THE VALUE OF COSHM(X) IF ISW .EQ. 0 OR C ISW .EQ. 1 AND CONTAINS THE VALUE OF COSHMM(X) IF ISW C .GE. 2 (COSHM IS UNALTERED IF ISW .EQ. -1). C C AND C C X AND ISW ARE UNALTERED. C C----------------------------------------------------------- C DATA SP5/.255251817302048E-09/, * SP4/.723809046696880E-07/, * SP3/.109233297700241E-04/, * SP2/.954811583154274E-03/, * SP1/.452867078563929E-01/, * SQ1/-.471329214363072E-02/ DATA CP5/.116744361560051E-08/, * CP4/.280407224259429E-06/, * CP3/.344417983443219E-04/, * CP2/.232293648552398E-02/, * CP1/.778752378267155E-01/, * CQ1/-.545809550662099E-02/ DATA ZP3/5.59297116264720E-07/, * ZP2/1.77943488030894E-04/, * ZP1/1.69800461894792E-02/, * ZQ4/1.33412535492375E-09/, * ZQ3/-5.80858944138663E-07/, * ZQ2/1.27814964403863E-04/, * ZQ1/-1.63532871439181E-02/ DATA CUT(1)/1.65/, CUT(2)/1.2/, CUT(3)/1.2/, CUT(4)/2.7/, * CUT(5)/1.65/ C XX = X AX = ABS(XX) XS = XX*XX IF (AX .GE. CUT(ISW+2)) EXPX = EXP(AX) C C SINHM APPROXIMATION C IF (ISW .EQ. 1 .OR. ISW .EQ. 2) GO TO 2 IF (AX .GE. 1.65) GO TO 1 SINHM = ((((((SP5*XS+SP4)*XS+SP3)*XS+SP2)*XS+SP1)*XS+1.) * *XS*XX)/((SQ1*XS+1.)*6.) GO TO 2 1 SINHM = -(((AX+AX)+1./EXPX)-EXPX)/2. IF (XX .LT. 0.) SINHM = -SINHM C C COSHM APPROXIMATION C 2 IF (ISW .NE. 0 .AND. ISW .NE. 1) GO TO 4 IF (AX .GE. 1.2) GO TO 3 COSHM = ((((((CP5*XS+CP4)*XS+CP3)*XS+CP2)*XS+CP1)*XS+1.) * *XS)/((CQ1*XS+1.)*2.) GO TO 4 3 COSHM = ((1./EXPX-2.)+EXPX)/2. C C COSHMM APPROXIMATION C 4 IF (ISW .LE. 1) RETURN IF (AX .GE. 2.70) GO TO 5 COSHM = ((((ZP3*XS+ZP2)*XS+ZP1)*XS+1.)*XS*XS)/(((((ZQ4 * *XS+ZQ3)*XS+ZQ2)*XS+ZQ1)*XS+1.)*24.) RETURN 5 COSHM = (((1./EXPX-2.)-XS)+EXPX)/2. RETURN END REAL FUNCTION ESUM (MU, X) C----------------------------------------------------------------------- C EVALUATION OF EXP(MU + X) C----------------------------------------------------------------------- IF (X .GT. 0.0) GO TO 10 C IF (MU .LT. 0) GO TO 20 W = MU + X IF (W .GT. 0.0) GO TO 20 ESUM = EXP(W) RETURN C 10 IF (MU .GT. 0) GO TO 20 W = MU + X IF (W .LT. 0.0) GO TO 20 ESUM = EXP(W) RETURN C 20 W = MU ESUM = EXP(W)*EXP(X) RETURN END DOUBLE PRECISION FUNCTION DESUM (MU, X) C----------------------------------------------------------------------- C EVALUATION OF EXP(MU + X) C----------------------------------------------------------------------- DOUBLE PRECISION X, W C IF (X .GT. 0.D0) GO TO 10 C IF (MU .LT. 0) GO TO 20 W = MU + X IF (W .GT. 0.D0) GO TO 20 DESUM = DEXP(W) RETURN C 10 IF (MU .GT. 0) GO TO 20 W = MU + X IF (W .LT. 0.D0) GO TO 20 DESUM = DEXP(W) RETURN C 20 W = MU DESUM = DEXP(W)*DEXP(X) RETURN END REAL FUNCTION REXP (X) C----------------------------------------------------------------------- C EVALUATION OF THE FUNCTION EXP(X) - 1 C----------------------------------------------------------------------- DATA P1/ .914041914819518E-09/, P2/ .238082361044469E-01/, * Q1/-.499999999085958E+00/, Q2/ .107141568980644E+00/, * Q3/-.119041179760821E-01/, Q4/ .595130811860248E-03/ C----------------------- IF (ABS(X) .GT. 0.15) GO TO 10 REXP = X*(((P2*X + P1)*X + 1.0)/((((Q4*X + Q3)*X + Q2)*X * + Q1)*X + 1.0)) RETURN C 10 IF (X .LT. 0.0) GO TO 20 E = EXP(X) REXP = E*(0.5 + (0.5 - 1.0/E)) RETURN 20 IF (X .LT. -37.0) GO TO 30 REXP = (EXP(X) - 0.5) - 0.5 RETURN 30 REXP = -1.0 RETURN END DOUBLE PRECISION FUNCTION DREXP (X) C----------------------------------------------------------------------- C EVALUATION OF THE FUNCTION EXP(X) - 1 C----------------------------------------------------------------------- DOUBLE PRECISION X, E, W, Z DOUBLE PRECISION A0, A1, A2, A3, A4, B1, B2, B3, B4 DOUBLE PRECISION C1, C2, C3, C4, C5 C--------------------------- DATA A0/ .248015873015873015873016D-04/, * A1/-.344452080605731005808147D-05/, * A2/ .206664230430046597475413D-06/, * A3/-.447300111094328162971036D-08/, * A4/ .114734027080634968083920D-11/ DATA B1/-.249994190011341852652396D+00/, * B2/ .249987228833107957725728D-01/, * B3/-.119037506846942249362528D-02/, * B4/ .228908693387350391768682D-04/ C--------------------------- C CI = 1/FACTORIAL(I + 2) C--------------------------- DATA C1 / .1666666666666666666666666666666667D+00/, * C2 / .4166666666666666666666666666666667D-01/, * C3 / .8333333333333333333333333333333333D-02/, * C4 / .1388888888888888888888888888888889D-02/, * C5 / .1984126984126984126984126984126984D-03/ C--------------------------- IF (DABS(X) .GT. 0.15D0) GO TO 10 C C Z IS A MINIMAX APPROXIMATION OF THE SERIES C C C6 + C7*X + C8*X**2 + .... C C THIS APPROXIMATION IS ACCURATE TO WITHIN C 1 UNIT OF THE 23-RD SIGNIFICANT DIGIT. C THE RESULTING VALUE FOR W IS ACCURATE TO C WITHIN 1 UNIT OF THE 33-RD SIGNIFICANT C DIGIT. C Z = ((((A4*X + A3)*X + A2)*X + A1)*X + A0) / * ((((B4*X + B3)*X + B2)*X + B1)*X + 1.D0) W = ((((((Z*X + C5)*X + C4)*X + C3)*X + C2)*X + * C1)*X + 0.5D0)*X + 1.D0 DREXP = X*W RETURN C 10 IF (X .LT. 0.D0) GO TO 20 E = DEXP(X) DREXP = E*(0.5D0 + (0.5D0 - 1.D0/E)) RETURN 20 IF (X .LT. -77.D0) GO TO 30 DREXP = (DEXP(X) - 0.5D0) - 0.5D0 RETURN 30 DREXP = -1.D0 RETURN END SUBROUTINE REXP1 (X, E, W) C----------------------------------------------------------------------- C C EVALUATION OF W = (EXP(X) - 1)/X C C E IS AN INPUT/OUTPUT VARIABLE. IF E .GE. 0 THEN IT IS ASSUMED C THAT E = EXP(X). IN THIS CASE E IS NOT MODIFIED. IF E .LT. 0 C THEN E IS SET TO EXP(X) WHEN THIS VALUE IS NEEDED. C C----------------------------------------------------------------------- DATA P1/ .914041914819518E-09/, P2/ .238082361044469E-01/, * Q1/-.499999999085958E+00/, Q2/ .107141568980644E+00/, * Q3/-.119041179760821E-01/, Q4/ .595130811860248E-03/ C----------------------- IF (ABS(X) .GT. 0.15) GO TO 10 W = ((P2*X + P1)*X + 1.0)/((((Q4*X + Q3)*X + Q2)*X * + Q1)*X + 1.0) RETURN C 10 IF (X .LT. 0.0) GO TO 20 IF (E .LT. 0.0) E = EXP(X) W = (E*(0.5 + (0.5 - 1.0/E)))/X RETURN 20 IF (X .LT. -37.0) GO TO 30 IF (E .LT. 0.0) E = EXP(X) W = ((E - 0.5) - 0.5)/X RETURN 30 W = -1.0/X RETURN END SUBROUTINE DREXP1 (X, E, W) C----------------------------------------------------------------------- C C EVALUATION OF W = (EXP(X) - 1)/X C C E IS AN INPUT/OUTPUT VARIABLE. IF E .GE. 0 THEN IT IS ASSUMED C THAT E = EXP(X). IN THIS CASE E IS NOT MODIFIED. IF E .LT. 0 C THEN E IS SET TO EXP(X) WHEN THIS VALUE IS NEEDED. C C----------------------------------------------------------------------- DOUBLE PRECISION X, E, W, Z DOUBLE PRECISION A0, A1, A2, A3, A4, B1, B2, B3, B4 DOUBLE PRECISION C1, C2, C3, C4, C5 C--------------------------- DATA A0/ .248015873015873015873016D-04/, * A1/-.344452080605731005808147D-05/, * A2/ .206664230430046597475413D-06/, * A3/-.447300111094328162971036D-08/, * A4/ .114734027080634968083920D-11/ DATA B1/-.249994190011341852652396D+00/, * B2/ .249987228833107957725728D-01/, * B3/-.119037506846942249362528D-02/, * B4/ .228908693387350391768682D-04/ C--------------------------- C CI = 1/FACTORIAL(I + 2) C--------------------------- DATA C1 / .1666666666666666666666666666666667D+00/, * C2 / .4166666666666666666666666666666667D-01/, * C3 / .8333333333333333333333333333333333D-02/, * C4 / .1388888888888888888888888888888889D-02/, * C5 / .1984126984126984126984126984126984D-03/ C--------------------------- W = 1.D0 IF (DABS(X) .LT. 1.D-33) RETURN IF (DABS(X) .GT. 0.15D0) GO TO 10 C C Z IS A MINIMAX APPROXIMATION OF THE SERIES C C C6 + C7*X + C8*X**2 + .... C C THIS APPROXIMATION IS ACCURATE TO WITHIN C 1 UNIT OF THE 23-RD SIGNIFICANT DIGIT. C THE RESULTING VALUE FOR W IS ACCURATE TO C WITHIN 1 UNIT OF THE 33-RD SIGNIFICANT C DIGIT. C Z = ((((A4*X + A3)*X + A2)*X + A1)*X + A0) / * ((((B4*X + B3)*X + B2)*X + B1)*X + 1.D0) W = ((((((Z*X + C5)*X + C4)*X + C3)*X + C2)*X + * C1)*X + 0.5D0)*X + 1.D0 RETURN C 10 IF (X .LT. 0.D0) GO TO 20 IF (E .LT. 0.D0) E = DEXP(X) W = (E*(0.5D0 + (0.5D0 - 1.D0/E)))/X RETURN 20 IF (X .LT. -77.D0) GO TO 30 IF (E .LT. 0.D0) E = DEXP(X) W = ((E - 0.5D0) - 0.5D0)/X RETURN 30 W = -1.D0/X RETURN END REAL FUNCTION ALNREL(A) C----------------------------------------------------------------------- C EVALUATION OF THE FUNCTION LN(1 + A) C----------------------------------------------------------------------- DATA P1/-.129418923021993E+01/, P2/.405303492862024E+00/, * P3/-.178874546012214E-01/ DATA Q1/-.162752256355323E+01/, Q2/.747811014037616E+00/, * Q3/-.845104217945565E-01/ C-------------------------- IF (ABS(A) .GT. 0.375) GO TO 10 T = A/(A + 2.0) T2 = T*T W = (((P3*T2 + P2)*T2 + P1)*T2 + 1.0)/ * (((Q3*T2 + Q2)*T2 + Q1)*T2 + 1.0) ALNREL = 2.0*T*W RETURN C 10 X = 1.0 + A IF (A .LT. 0.0) X = (A + 0.5) + 0.5 ALNREL = ALOG(X) RETURN END DOUBLE PRECISION FUNCTION DLNREL (A) C----------------------------------------------------------------------- C EVALUATION OF THE FUNCTION LN(1 + A) C----------------------------------------------------------------------- DOUBLE PRECISION A, T, T2, W, Z DOUBLE PRECISION P0, P1, P2, P3, Q1, Q2, Q3, Q4 DOUBLE PRECISION C1, C2, C3, C4, C5 C------------------------- DATA P0 / .7692307692307692307680D-01/, * P1 /-.1505958055914600184836D+00/, * P2 / .9302355725278521726994D-01/, * P3 /-.1787900022182327735804D-01/ DATA Q1 /-.2824412139355646910683D+01/, * Q2 / .2892424216041495392509D+01/, * Q3 /-.1263560605948009364422D+01/, * Q4 / .1966769435894561313526D+00/ C------------------------- C CI = 1/(2I + 1) C------------------------- DATA C1 /.3333333333333333333333333333333D+00/, * C2 /.2000000000000000000000000000000D+00/, * C3 /.1428571428571428571428571428571D+00/, * C4 /.1111111111111111111111111111111D+00/, * C5 /.9090909090909090909090909090909D-01/ C------------------------- IF (DABS(A) .LT. 0.375D0) GO TO 10 T = 1.D0 + A IF (A .LT. 0.D0) T = 0.5D0 + (0.5D0 + A) DLNREL = DLOG(T) RETURN C C W IS A MINIMAX APPROXIMATION OF THE SERIES C C C6 + C7*T**2 + C8*T**4 + ... C C THIS APPROXIMATION IS ACCURATE TO WITHIN C 1.6 UNITS OF THE 21-ST SIGNIFICANT DIGIT. C THE RESULTING VALUE FOR 1.D0 + T2*Z IS C ACCURATE TO WITHIN 1 UNIT OF THE 30-TH C SIGNIFICANT DIGIT. C 10 T = A/(A + 2.D0) T2 = T*T W = (((P3*T2 + P2)*T2 + P1)*T2 + P0)/ * ((((Q4*T2 + Q3)*T2 + Q2)*T2 + Q1)*T2 + 1.D0) C Z = ((((W*T2 + C5)*T2 + C4)*T2 + C3)*T2 + C2)*T2 + C1 DLNREL = 2.D0*T*(1.D0 + T2*Z) RETURN END REAL FUNCTION RLOG(X) C----------------------------------------------------------------------- C EVALUATION OF THE FUNCTION X - 1 - LN(X) C----------------------------------------------------------------------- C A = RLOG (0.7) C B = RLOG (4/3) C------------------------ DATA A/.566749439387324E-01/ DATA B/.456512608815524E-01/ C------------------------ DATA P0/ .333333333333333E+00/, P1/-.224696413112536E+00/, * P2/ .620886815375787E-02/ DATA Q1/-.127408923933623E+01/, Q2/ .354508718369557E+00/ C------------------------ IF (X .LT. 0.61 .OR. X .GT. 1.57) GO TO 100 IF (X .LT. 0.82) GO TO 10 IF (X .GT. 1.18) GO TO 20 C C ARGUMENT REDUCTION C U = (X - 0.5) - 0.5 UP2 = U + 2.0 W1 = 0.0 GO TO 30 C 10 U = (X - 0.7)/0.7 UP2 = U + 2.0 W1 = A - U*0.3 GO TO 30 C 20 T = 0.75*(X - 1.0) U = T - 0.25 UP2 = T + 1.75 W1 = B + U/3.0 C C SERIES EXPANSION C 30 R = U/UP2 T = R*R W = ((P2*T + P1)*T + P0)/((Q2*T + Q1)*T + 1.0) RLOG = R*(U - 2.0*T*W) + W1 RETURN C C 100 R = (X - 0.5) - 0.5 RLOG = R - ALOG(X) RETURN END REAL FUNCTION RLOG1(X) C----------------------------------------------------------------------- C EVALUATION OF THE FUNCTION X - LN(1 + X) C----------------------------------------------------------------------- C A = RLOG (0.7) C B = RLOG (4/3) C------------------------ DATA A/.566749439387324E-01/ DATA B/.456512608815524E-01/ C------------------------ DATA P0/ .333333333333333E+00/, P1/-.224696413112536E+00/, * P2/ .620886815375787E-02/ DATA Q1/-.127408923933623E+01/, Q2/ .354508718369557E+00/ C------------------------ IF (X .LT. -0.39 .OR. X .GT. 0.57) GO TO 100 IF (X .LT. -0.18) GO TO 10 IF (X .GT. 0.18) GO TO 20 C C ARGUMENT REDUCTION C U = X UP2 = U + 2.0 W1 = 0.0 GO TO 30 C 10 U = (X + 0.3)/0.7 UP2 = U + 2.0 W1 = A - U*0.3 GO TO 30 C 20 T = 0.75*X U = T - 0.25 UP2 = T + 1.75 W1 = B + U/3.0 C C SERIES EXPANSION C 30 R = U/UP2 T = R*R W = ((P2*T + P1)*T + P0)/((Q2*T + Q1)*T + 1.0) RLOG1 = R*(U - 2.0*T*W) + W1 RETURN C C 100 W = (X + 0.5) + 0.5 RLOG1 = X - ALOG(W) RETURN END DOUBLE PRECISION FUNCTION DRLOG (X) C----------------------------------------------------------------------- C EVALUATION OF THE FUNCTION X - 1 - LN(X) C----------------------------------------------------------------------- DOUBLE PRECISION X DOUBLE PRECISION A, B, R, T, U, UP2, W, W1, Z DOUBLE PRECISION P0, P1, P2, P3, Q1, Q2, Q3, Q4 DOUBLE PRECISION C1, C2, C3, C4, C5 C------------------------- C A = DRLOG (0.7) C B = DRLOG (4/3) C------------------------- DATA A /.566749439387323789126387112411845D-01/ DATA B /.456512608815524058941143273395059D-01/ C------------------------- DATA P0 / .7692307692307692307680D-01/, * P1 /-.1505958055914600184836D+00/, * P2 / .9302355725278521726994D-01/, * P3 /-.1787900022182327735804D-01/ DATA Q1 /-.2824412139355646910683D+01/, * Q2 / .2892424216041495392509D+01/, * Q3 /-.1263560605948009364422D+01/, * Q4 / .1966769435894561313526D+00/ C------------------------- C CI = 1/(2I + 1) C------------------------- DATA C1 /.333333333333333333333333333333333D+00/, * C2 /.200000000000000000000000000000000D+00/, * C3 /.142857142857142857142857142857143D+00/, * C4 /.111111111111111111111111111111111D+00/, * C5 /.909090909090909090909090909090909D-01/ C------------------------- IF (X .LT. 0.61D0 .OR. X .GT. 1.57D0) GO TO 100 IF (X .LT. 0.82D0) GO TO 10 IF (X .GT. 1.18D0) GO TO 20 C C ARGUMENT REDUCTION C U = (X - 0.5D0) - 0.5D0 UP2 = U + 2.D0 W1 = 0.D0 GO TO 30 C 10 U = (X - 0.7D0)/0.7D0 UP2 = U + 2.D0 W1 = A - U*0.3D0 GO TO 30 C 20 T = 0.75D0*(X - 1.D0) U = T - 0.25D0 UP2 = T + 1.75D0 W1 = B + U/3.D0 C C SERIES EXPANSION C 30 R = U/UP2 T = R*R C C Z IS A MINIMAX APPROXIMATION OF THE SERIES C C C6 + C7*R**2 + C8*R**4 + ... C C FOR THE INTERVAL (0.0, 0.375). THE APPROX- C IMATION IS ACCURATE TO WITHIN 1.6 UNITS OF C THE 21-ST SIGNIFICANT DIGIT. C Z = (((P3*T + P2)*T + P1)*T + P0)/ * ((((Q4*T + Q3)*T + Q2)*T + Q1)*T + 1.D0) C W = ((((Z*T + C5)*T + C4)*T + C3)*T + C2)*T + C1 DRLOG = R*(U - 2.D0*T*W) + W1 RETURN C C 100 R = (X - 0.5D0) - 0.5D0 DRLOG = R - DLOG(X) RETURN END DOUBLE PRECISION FUNCTION DRLOG1 (X) C----------------------------------------------------------------------- C EVALUATION OF THE FUNCTION X - LN(1 + X) C----------------------------------------------------------------------- DOUBLE PRECISION X DOUBLE PRECISION A, B, R, T, U, UP2, W, W1, Z DOUBLE PRECISION P0, P1, P2, P3, Q1, Q2, Q3, Q4 DOUBLE PRECISION C1, C2, C3, C4, C5 C------------------------- C A = DRLOG (0.7) C B = DRLOG (4/3) C------------------------- DATA A /.566749439387323789126387112411845D-01/ DATA B /.456512608815524058941143273395059D-01/ C------------------------- DATA P0 / .7692307692307692307680D-01/, * P1 /-.1505958055914600184836D+00/, * P2 / .9302355725278521726994D-01/, * P3 /-.1787900022182327735804D-01/ DATA Q1 /-.2824412139355646910683D+01/, * Q2 / .2892424216041495392509D+01/, * Q3 /-.1263560605948009364422D+01/, * Q4 / .1966769435894561313526D+00/ C------------------------- C CI = 1/(2I + 1) C------------------------- DATA C1 /.333333333333333333333333333333333D+00/, * C2 /.200000000000000000000000000000000D+00/, * C3 /.142857142857142857142857142857143D+00/, * C4 /.111111111111111111111111111111111D+00/, * C5 /.909090909090909090909090909090909D-01/ C------------------------- IF (X .LT. -0.39D0 .OR. X .GT. 0.57D0) GO TO 100 IF (X .LT. -0.18D0) GO TO 10 IF (X .GT. 0.18D0) GO TO 20 C C ARGUMENT REDUCTION C U = X UP2 = U + 2.D0 W1 = 0.D0 GO TO 30 C 10 U = (X + 0.3D0)/0.7D0 UP2 = U + 2.D0 W1 = A - U*0.3D0 GO TO 30 C 20 T = 0.75D0*X U = T - 0.25D0 UP2 = T + 1.75D0 W1 = B + U/3.D0 C C SERIES EXPANSION C 30 R = U/UP2 T = R*R C C Z IS A MINIMAX APPROXIMATION OF THE SERIES C C C6 + C7*R**2 + C8*R**4 + ... C C FOR THE INTERVAL (0.0, 0.375). THE APPROX- C IMATION IS ACCURATE TO WITHIN 1.6 UNITS OF C THE 21-ST SIGNIFICANT DIGIT. C Z = (((P3*T + P2)*T + P1)*T + P0)/ * ((((Q4*T + Q3)*T + Q2)*T + Q1)*T + 1.D0) C W = ((((Z*T + C5)*T + C4)*T + C3)*T + C2)*T + C1 DRLOG1 = R*(U - 2.D0*T*W) + W1 RETURN C C 100 W = (X + 0.5D0) + 0.5D0 DRLOG1 = X - DLOG(W) RETURN END SUBROUTINE LOCPT (X0, Y0, X, Y, N, L, M) REAL X(N), Y(N) C----------------------------------------------------------------------- C GIVEN A POLYGONAL LINE CONNECTING THE VERTICES (X(I),Y(I)) C (I = 1,...,N) TAKEN IN THIS ORDER. IT IS ASSUMED THAT THE C POLYGONAL PATH IS A LOOP, WHERE (X(N),Y(N)) = (X(1),Y(1)) C OR THERE IS AN ARC FROM (X(N),Y(N)) TO (X(1),Y(1)). C C (X0,Y0) IS AN ARBITRARY POINT AND L AND M ARE VARIABLES. C L AND M ARE ASSIGNED THE FOLLOWING VALUES ... C C L = -1 IF (X0,Y0) IS OUTSIDE THE POLYGONAL PATH C L = 0 IF (X0,Y0) LIES ON THE POLYGONAL PATH C L = 1 IF (X0,Y0) IS INSIDE THE POLYGONAL PATH C C M = 0 IF (X0,Y0) IS ON OR OUTSIDE THE PATH. IF (X0,Y0) C IS INSIDE THE PATH THEN M IS THE WINDING NUMBER OF THE C PATH AROUND THE POINT (X0,Y0). C C----------------------- C C ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE C SMALLEST NUMBER SUCH THAT 1.0 + EPS .GT. 1.0 C EPS = SPMPAR(1) C C----------------------------------------------------------------------- N0 = N IF (X(1) .EQ. X(N) .AND. Y(1) .EQ. Y(N)) N0 = N - 1 PI = ATAN2(0.0, -1.0) PI2 = 2.0*PI TOL = 4.0*EPS*PI L = -1 M = 0 C U = X(1) - X0 V = Y(1) - Y0 IF (U .EQ. 0.0 .AND. V .EQ. 0.0) GO TO 20 IF (N0 .LT. 2) RETURN THETA1 = ATAN2(V, U) C SUM = 0.0 THETA = THETA1 DO 10 I = 2,N0 U = X(I) - X0 V = Y(I) - Y0 IF (U .EQ. 0.0 .AND. V .EQ. 0.0) GO TO 20 THETAI = ATAN2(V, U) C ANGLE = ABS(THETAI - THETA) IF (ABS(ANGLE - PI) .LT. TOL) GO TO 20 IF (ANGLE .GT. PI) ANGLE = ANGLE - PI2 IF (THETA .GT. THETAI) ANGLE = -ANGLE SUM = SUM + ANGLE THETA = THETAI 10 CONTINUE C ANGLE = ABS(THETA1 - THETA) IF (ABS(ANGLE - PI) .LT. TOL) GO TO 20 IF (ANGLE .GT. PI) ANGLE = ANGLE - PI2 IF (THETA .GT. THETA1) ANGLE = -ANGLE SUM = SUM + ANGLE C C SUM = 2*PI*M WHERE M IS THE WINDING NUMBER C M = ABS(SUM)/PI2 + 0.2 IF (M .EQ. 0) RETURN L = 1 IF (SUM .LT. 0.0) M = -M RETURN C C (X0, Y0) IS ON THE BOUNDARY OF THE PATH C 20 L = 0 RETURN END SUBROUTINE PFIND (A, B, X, Y, N, U, V, M, NUM, IERR) C----------------------------------------------------------------------- C C INTERSECTION OF A STRIGHT LINE C AND POLYGONAL PATH C C----------------------------------------------------------------------- REAL A(2), B(2), X(N), Y(N), U(M), V(M) REAL K, KI C---------------------- C C ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE C SMALLEST NUMBER SUCH THAT 1.0 + EPS .GT. 1.0 . C EPS = SPMPAR(1) C C---------------------- NUM = 0 IF (N .LT. 2) GO TO 200 H = B(1) - A(1) K = B(2) - A(2) IF (H .EQ. 0.0 .AND. K .EQ. 0.0) GO TO 200 C IERR = 0 NM1 = N - 1 TOL = 4.0*EPS TOL0 = 2.0*EPS ONEP = 1.0 + TOL ONEM = 0.5 + (0.5 - TOL0) C IND = 0 DO 100 I = 1, NM1 HI = X(I + 1) - X(I) KI = Y(I + 1) - Y(I) IF (HI .EQ. 0.0 .AND. KI .EQ. 0.0) GO TO 100 IND = 1 C C CHECK IF THE LINE FROM A TO B AND THE I-TH C LINE IN THE PATH ARE PARALLEL C S = HI*K T = H*KI D = S - T IF (ABS(D) .LE. TOL*AMAX1(ABS(S),ABS(T))) GO TO 40 C----------------------------------------------------------------------- C THE LINES ARE NOT PARALLEL C----------------------------------------------------------------------- P = X(I) - A(1) Q = Y(I) - A(2) S = HI*Q T = KI*P DIFF = S - T IF (ABS(DIFF) .LE. TOL*AMAX1(ABS(S),ABS(T))) DIFF = 0.0 S = H*Q T = K*P DIFF1 = S - T IF (ABS(DIFF1) .LE. TOL*AMAX1(ABS(S),ABS(T))) DIFF1 = 0.0 C S = DIFF/D T = DIFF1/D IF (S .LT. 0.0 .OR. S .GT. ONEP) GO TO 100 IF (T .LT. 0.0 .OR. T .GT. ONEP) GO TO 100 IF (NUM .GT. 0 .AND. T .EQ. 0.0) GO TO 100 IF (S .GT. 0.0) GO TO 20 C C POINT A IS ON THE I-TH LINE C 10 NUM = NUM + 1 IF (NUM .GT. M) GO TO 210 U(NUM) = A(1) V(NUM) = A(2) GO TO 100 C C POINT B IS ON THE I-TH LINE C 20 IF (S .LT. ONEM) GO TO 30 21 NUM = NUM + 1 IF (NUM .GT. M) GO TO 210 U(NUM) = B(1) V(NUM) = B(2) GO TO 100 C C THE INTERIOR OF THE LINE FROM A TO B C INTERSECTS WITH THE I-TH LINE C 30 NUM = NUM + 1 IF (NUM .GT. M) GO TO 210 U(NUM) = A(1) + S*H V(NUM) = A(2) + S*K GO TO 100 C----------------------------------------------------------------------- C THE LINES ARE PARALLEL C----------------------------------------------------------------------- 40 IF (ABS(HI) .GT. ABS(KI)) GO TO 50 C D = A(2) - Y(I) IF (ABS(D) .LE. TOL0*AMAX1(ABS(A(2)),ABS(Y(I)))) D = 0.0 S = D/KI C P = X(I) + S*HI IF (ABS(A(1) - P) .GT. TOL*AMAX1(ABS(A(1)),ABS(P))) * GO TO 100 C D = B(2) - Y(I) IF (ABS(D) .LE. TOL0*AMAX1(ABS(B(2)),ABS(Y(I)))) D = 0.0 T = D/KI GO TO 60 C 50 D = A(1) - X(I) IF (ABS(D) .LE. TOL0*AMAX1(ABS(A(1)),ABS(X(I)))) D = 0.0 S = D/HI C P = Y(I) + S*KI IF (ABS(P - A(2)) .GT. TOL*AMAX1(ABS(P),ABS(A(2)))) * GO TO 100 C D = B(1) - X(I) IF (ABS(D) .LE. TOL0*AMAX1(ABS(B(1)),ABS(X(I)))) D = 0.0 T = D/HI C C THE 2 LINES ARE PORTIONS OF THE SAME C STRAIGHT INFINITE LINE C 60 IF (S .GT. 0.0 .AND. S .LT. ONEM) GO TO 220 IF (T .GT. 0.0 .AND. T .LT. ONEM) GO TO 220 TMIN = AMIN1(S,T) TMAX = AMAX1(S,T) IF (TMAX .LE. 0.0) GO TO 70 IF (TMIN .GE. ONEM) GO TO 80 GO TO 220 C 70 IF (TMAX .LT. 0.0) GO TO 100 IF (NUM .GT. 0) GO TO 100 IF (TMAX .EQ. S) GO TO 10 GO TO 21 C 80 IF (TMIN .GT. 1.0) GO TO 100 IF (TMIN .EQ. S) GO TO 10 GO TO 21 C 100 CONTINUE IF (IND .EQ. 0) GO TO 200 C IF (NUM .LT. 2) RETURN IF (U(NUM) .EQ. X(1) .AND. V(NUM) .EQ. Y(1)) * NUM = NUM - 1 RETURN C C ERROR RETURN C 200 IERR = 1 RETURN 210 IERR = 2 NUM = NUM - 1 RETURN 220 IERR = -I RETURN END SUBROUTINE HULL (X, Y, M, BX, BY, K, VX, VY, N) C----------------------------------------------------------------------- C OBTAINING THE CONVEX HULL FOR A FINITE PLANAR SET C----------------------------------------------------------------------- REAL X(M), Y(M) REAL BX(*), BY(*), VX(*), VY(*) LOGICAL IBEG C--------------------- C C ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE C SMALLEST NUMBER SUCH THAT 1.0 + EPS .GT. 1.0. C EPS = SPMPAR(1) C C--------------------- MP1 = M + 1 ONEP = 1.0 + 4.0*EPS C C REORDER X AND Y C CALL RRSORT (Y, X, M) YMIN = Y(1) YMAX = Y(M) IF (YMIN .EQ. YMAX) GO TO 500 C L = 1 10 L = L + 1 IF (Y(L) .EQ. YMIN) GO TO 10 LMIN = L L = L - 1 CALL RRSORT (X, Y, L) X1 = X(1) C I = M 20 I = I - 1 IF (Y(I) .EQ. YMAX) GO TO 20 LMAX = I I = I + 1 CALL RRSORT (X(I), Y(I), M - LMAX) XM = X(M) C C FIND XMIN AND XMAX C XMIN = X1 XMAX = X(L) DO 31 I = LMIN,M IF (X(I) .GT. XMIN) GO TO 30 XMIN = X(I) GO TO 31 30 IF (X(I) .GT. XMAX) XMAX = X(I) 31 CONTINUE C C GOING ALONG THE YMIN AXIS C K = L DO 50 I = 1,L BX(I) = X(I) BY(I) = Y(I) 50 CONTINUE C N = 1 VX(1) = X(1) VY(1) = Y(1) IF (L .EQ. 1) GO TO 100 N = 2 VX(2) = X(L) VY(2) = Y(L) C C GOING FROM THE YMIN AXIS TO THE XMAX AXIS C 100 H = XMAX - BX(K) IF (H .EQ. 0.0) GO TO 150 K0 = K IBEG = .TRUE. C 110 CONTINUE L = L + 1 IF (L .GT. LMAX) L = M H = X(L) - BX(K) IF (H .LE. 0.0) GO TO 110 DX = X(L) - BX(K0) DY = Y(L) - BY(K0) IF (IBEG) GO TO 120 R = (DX0/DX)*DY IF (R .GT. ONEP*DY0) GO TO 130 IF (DY0 .GT. ONEP*R) GO TO 120 IF (DY0 .EQ. 0.0 .AND. DY .GT. 0.0) GO TO 140 K = K + 1 GO TO 121 120 IBEG = .FALSE. DX0 = DX DY0 = DY K = K0 + 1 121 BX(K) = X(L) BY(K) = Y(L) LSAV = L 130 H = XMAX - X(L) IF (H .GT. 0.0) GO TO 110 C 140 L = LSAV N = N + 1 VX(N) = BX(K) VY(N) = BY(K) GO TO 100 C C GOING ALONG THE XMAX AXIS C 150 IF (L .EQ. M) GO TO 250 KSAV = K I = L 151 IF (I .EQ. LMAX) GO TO 160 I = I + 1 IF (X(I) .NE. XMAX) GO TO 151 L = I K = K + 1 BX(K) = X(I) BY(K) = Y(I) GO TO 151 C 160 XMAX = X(L) H = XMAX - XM IF (H .LE. 0.0) GO TO 170 IF (L .NE. LMAX) GO TO 200 IF (K .EQ. KSAV) GO TO 170 N = N + 1 VX(N) = BX(K) VY(N) = BY(K) C 170 L = M K = K + 1 BX(K) = XM BY(K) = Y(M) N = N + 1 VX(N) = XM VY(N) = Y(M) GO TO 250 C C GOING FROM THE YMAX AXIS TO THE XMAX AXIS C (HERE WE ARE TRAVERSING THE BOUNDARY CLOCKWISE) C 200 J = MP1 NN = MP1 BX(MP1) = XM VX(MP1) = XM BY(MP1) = Y(M) VY(MP1) = Y(M) I = LMAX + 1 201 J0 = J IBEG = .TRUE. C 210 CONTINUE I = I - 1 H = X(I) - BX(J) IF (H .LE. 0.0) GO TO 210 DX = X(I) - BX(J0) DY = ABS(Y(I) - BY(J0)) IF (IBEG) GO TO 220 R = (DX0/DX)*DY IF (R .GT. ONEP*DY0) GO TO 230 IF (DY0 .GT. ONEP*R) GO TO 220 IF (DY0 .EQ. 0.0 .AND. DY .GT. 0.0) GO TO 235 J = J - 1 GO TO 221 220 IBEG = .FALSE. DX0 = DX DY0 = DY J = J0 - 1 221 BX(J) = X(I) BY(J) = Y(I) ISAV = I 230 H = XMAX - X(I) IF (H .GT. 0.0) GO TO 210 C 235 I = ISAV NN = NN - 1 VX(NN) = BX(J) VY(NN) = BY(J) H = XMAX - BX(J) IF (H .GT. 0.0) GO TO 201 C C UPDATE BX,BY AND VX,VY SO THAT THE BOUNDARY C IS AGAIN BEING TRAVERSED COUNTERCLOCKWISE C IF (I .EQ. L .AND. K .EQ. KSAV) NN = NN + 1 DO 240 II = NN,MP1 N = N + 1 VX(N) = VX(II) VY(N) = VY(II) 240 CONTINUE C IF (I .EQ. L) J = J + 1 DO 245 II = J,MP1 K = K + 1 BX(K) = BX(II) BY(K) = BY(II) 245 CONTINUE L = M C C GOING ALONG THE YMAX AXIS C 250 LBEG = LMAX + 1 IF (LBEG .EQ. M) GO TO 260 MM1 = M - 1 DO 251 I = LBEG,MM1 L = L - 1 K = K + 1 BX(K) = X(L) BY(K) = Y(L) 251 CONTINUE N = N + 1 VX(N) = BX(K) VY(N) = BY(K) C 260 IF (K .EQ. M) GO TO 370 H = XMAX - BX(K) IF (H .GT. 0.0) GO TO 300 H = BX(K) - XMIN IF (H .GT. 0.0) GO TO 301 GO TO 370 C C GOING FROM THE YMAX AXIS TO THE XMIN AXIS C 300 H = BX(K) - XMIN IF (H .EQ. 0.0) GO TO 350 301 K0 = K IBEG = .TRUE. C 310 CONTINUE L = L - 1 IF (L .LT. LMIN) L = 1 H = X(L) - BX(K) IF (H .GE. 0.0) GO TO 310 DX = ABS(X(L) - BX(K0)) DY = ABS(Y(L) - BY(K0)) IF (IBEG) GO TO 320 R = (DX0/DX)*DY IF (R .GT. ONEP*DY0) GO TO 330 IF (DY0 .GT. ONEP*R) GO TO 320 IF (DY0 .EQ. 0.0 .AND. DY .GT. 0.0) GO TO 340 IF (K .EQ. MP1) GO TO 330 K = K + 1 GO TO 321 320 IBEG = .FALSE. DX0 = DX DY0 = DY K = K0 + 1 321 BX(K) = X(L) BY(K) = Y(L) LSAV = L 330 H = X(L) - XMIN IF (H .GT. 0.0) GO TO 310 C 340 L = LSAV N = N + 1 VX(N) = BX(K) VY(N) = BY(K) IF (L .EQ. 1) RETURN IF (K .EQ. M) GO TO 370 GO TO 300 C C GOING ALONG THE XMIN AXIS C 350 KSAV = K I = L 351 IF (I .EQ. LMIN) GO TO 360 I = I - 1 IF (X(I) .NE. XMIN) GO TO 351 L = I K = K + 1 BX(K) = X(I) BY(K) = Y(I) GO TO 351 C 360 XMIN = X(L) H = X1 - XMIN IF (H .LE. 0.0) GO TO 370 IF (K .EQ. KSAV) GO TO 365 N = N + 1 VX(N) = BX(K) VY(N) = BY(K) 365 IF (L .NE. LMIN) GO TO 400 C 370 K = K + 1 BX(K) = X1 BY(K) = Y(1) N = N + 1 VX(N) = X1 VY(N) = Y(1) RETURN C C GOING FROM THE YMIN AXIS TO THE XMIN AXIS C (HERE WE ARE TRAVERSING THE BOUNDARY CLOCKWISE) C 400 IF (K .EQ. M) GO TO 370 KP1 = K + 1 J = MP1 NN = MP1 BX(MP1) = X1 VX(MP1) = X1 BY(MP1) = Y(1) VY(MP1) = Y(1) I = LMIN - 1 401 J0 = J IBEG = .TRUE. C 410 CONTINUE I = I + 1 H = X(I) - BX(J) IF (H .GE. 0.0) GO TO 410 DX = ABS(X(I) - BX(J0)) DY = Y(I) - BY(J0) IF (IBEG) GO TO 420 R = (DX0/DX)*DY IF (R .GT. ONEP*DY0) GO TO 430 IF (DY0 .GT. ONEP*R) GO TO 420 IF (DY0 .EQ. 0.0 .AND. DY .GT. 0.0) GO TO 440 IF (J .EQ. KP1) GO TO 430 J = J - 1 GO TO 421 420 IBEG = .FALSE. DX0 = DX DY0 = DY J = J0 - 1 421 BX(J) = X(I) BY(J) = Y(I) ISAV = I 430 H = X(I) - XMIN IF (H .GT. 0.0) GO TO 410 C 440 I = ISAV NN = NN - 1 VX(NN) = BX(J) VY(NN) = BY(J) IF (J .EQ. KP1) GO TO 450 H = BX(J) - XMIN IF (H .GT. 0.0) GO TO 401 C C UPDATE BX,BY AND VX,VY SO THAT THE BOUNDARY C IS AGAIN BEING TRAVERSED COUNTERCLOCKWISE C 450 IF (NN .EQ. N) GO TO 470 IF (I .EQ. L) NN = NN + 1 DO 451 II = NN,MP1 N = N + 1 VX(N) = VX(II) VY(N) = VY(II) 451 CONTINUE C IF (J .EQ. K) GO TO 471 IF (I .EQ. L) J = J + 1 DO 460 II = J,MP1 K = K + 1 BX(K) = BX(II) BY(K) = BY(II) 460 CONTINUE RETURN C 470 N = MP1 471 K = MP1 RETURN C C CASE WHEN YMIN = YMAX C 500 CALL RRSORT (X, Y, M) DO 510 I = 1,M BX(I) = X(I) BY(I) = Y(I) 510 CONTINUE K = MP1 BX(K) = BX(1) BY(K) = BY(1) C N = 3 VX(1) = X(1) VX(2) = X(M) VX(3) = X(1) VY(1) = Y(1) VY(2) = Y(M) VY(3) = Y(1) RETURN END REAL FUNCTION PAREA(X, Y, NB) INTEGER NB REAL X(NB), Y(NB) C C***************************************************************** C C GIVEN A SEQUENCE OF NB POINTS (X(I),Y(I)). PAREA COMPUTES C THE AREA BOUNDED BY THE CLOSED POLYGONAL CURVE WHICH PASSES C THROUGH THE POINTS IN THE ORDER THAT THEY ARE INDEXED. THE C FINAL POINT OF THE CURVE IS ASSUMED TO BE THE FIRST POINT C GIVEN. THEREFORE, IT NEED NOT BE LISTED AT THE END OF X AND C Y. THE CURVE IS NOT REQUIRED TO BE SIMPLE. C C***************************************************************** C N = NB IF (X(1) .EQ. X(N) .AND. Y(1) .EQ. Y(N)) N = N - 1 IF (N - 3) 10, 20, 30 C 10 PAREA = 0.0 RETURN C 20 PAREA= 0.5*((X(2) - X(1))*(Y(3) - Y(1)) * - (X(3) - X(1))*(Y(2) - Y(1))) RETURN C 30 NM1 = N - 1 A = X(1)*(Y(2) - Y(N)) + X(N)*(Y(1) - Y(NM1)) DO 31 I = 2, NM1 31 A = A + X(I)*(Y(I+1) - Y(I-1)) PAREA = 0.5*A RETURN END SUBROUTINE HC (IND, M, N, PR, AR, NB, S, IWK, NUM) C C SUBROUTINE TO FIND ONE OR MORE HAMILTONIAN CIRCUITS IN A C DIRECTED GRAPH OF N VERTICES ( N .GT. 1 ) REPRESENTED C BY THE INTEGERS 1, 2, ..., N AND M ARCS. C C INPUT ... C C IND = 0 ON AN INITIAL CALL TO HC. C = 1 OBTAIN ANOTHER HAMILTONIAN CIRCUIT. C = 2 MORE BACK TRACKS ARE BEING PERMITTED. C = 3 RESTORE THE ORGINAL ARRAY AR. C M = NUMBER OF ARCS. C N = NUMBER OF VERTICES. C PR(I) = SUM OF THE OUT-DEGREES OF VERTICES 1, ..., I-1 C (PR(1) = 0 , PR(N+1) = M). C AR = ADJACENCY LIST. THE ELEMENTS FROM AR(PR(I)+1) TO C AR(PR(I+1)) ARE A RECORD CONTAINING,IN ANY ORDER, C ALL THE VERTICES J SUCH THAT ARC (I,J) EXISTS. C THE GRAPH SHOULD NOT CONTAIN ARCS STARTING AND C ENDING AT THE SAME VERTEX. C NB = UPPER BOUND ON THE NUMBER OF BACK TRACKS TO BE C PERFORMED. (NB = -1 IF NO LIMIT IS TO BE PLACED C ON THE NUMBER OF BACK TRACKS TAKEN.) C NUM = DIMENSION OF THE WORK SPACE IWK. IT IS ASSUMED THAT C NUM .GE. M + 8*N + 20. C C OUTPUT ... C C IND = 1 A HAMILTONIAN CIRCUIT WAS FOUND. TO FIND ANOTHER C CIRCUIT, RESET NB AND RECALL THE ROUTINE. C THE ARRAY AR HAS BEEN MODIFIED. IF ONE DOES NOT C WISH TO OBTAIN ANOTHER CIRCUIT, SET IND = 3 AND C RECALL THE ROUTINE. THIS WILL RESTORE AR. C = 2 THE MAXIMUM NUMBER OF BACK TRACKS WERE PERFORMED. C TO CONTINUE, RESET NB AND RECALL THE ROUTINE. C THE ARRAY AR HAS BEEN MODIFIED. IF ONE DOES NOT C WISH TO CONTINUE, SET IND = 3 AND RECALL THE C ROUTINE. THIS WILL RESTORE AR. C = 4 NO CIRCUITS WERE FOUND. THE ARRAY AR HAS BEEN C RESTORED (SEE THE REMARK BELOW) AND THE PROCEDURE C IS FINISHED. C = -1 (INPUT ERROR) IND .LT. 0 OR IND .GT. 3 ON INPUT. C = -2 (INPUT ERROR) IND WAS MODIFIED. RESET IND TO ITS C PREVIOUS OUTPUT VALUE AND RERUN THE CODE. C = -3 (INPUT ERROR) THE INPUT SETTING IND = 3 CAN BE C USED ONLY WHEN THE PREVIOUS OUTPUT VALUE FOR C IND WAS 1 OR 2. IF THE PREVIOUS OUTPUT VALUE C FOR IND WAS 4, THEN THE ARRAY AR HAS ALREADY C BEEN RESTORED AND THERE IS NOTHING TO BE DONE. C = -4 (INPUT ERROR) NUM .LT. M + 8*N + 20. C = -5 (INPUT ERROR) PR(1) .NE. 0 OR PR(N+1) .NE. M. C = -6 (INPUT ERROR) PR(I) .GT. PR(I+1) FOR SOME I. C NB = NUMBER OF BACK TRACKS PERFORMED. C S(I) = I-TH VERTEX IN THE HAMILTONIAN CIRCUIT FOUND. C C WORK SPACE ... IWK C C REMARK. IN AR, THE ORDER OF THE ARCS IN EACH RECORD MAY BE C ALTERED BY THE ROUTINE. C C INTEGER PR(N + 1), AR(M), S(N), IWK(M + 8*N + 20) C INTEGER PR(*), AR(M), S(N), IWK(NUM) INTEGER S0, PC, AC, VR, VC, P, SUBR, RBUS, TOR C NP1 = N + 1 IF (IND .LT. 0 .OR. IND .GT. 3) GO TO 20 IF (NUM .LT. M + 8*N + 20) GO TO 30 IF (PR(1) .NE. 0 .OR. PR(NP1) .NE. M) GO TO 40 C S0 = 20 PC = S0 + N AC = PC + NP1 VR = AC + M VC = VR + N P = VC + N SUBR = P + N RBUS = SUBR + N TOR = RBUS + N C CALL HC1 (IND, M, N, PR, AR, NB, IWK(S0), NP1, IWK(PC), * IWK(AC), IWK(VR), IWK(VC), IWK(P), IWK(SUBR), * IWK(RBUS), IWK(TOR), IWK(1), IWK(2), IWK(3)) IF (IND .NE. 1) RETURN C II = S0 DO 10 I = 1,N S(I) = IWK(II) II = II + 1 10 CONTINUE RETURN C C ERROR RETURN C 20 IND = -1 RETURN 30 IND = -4 RETURN 40 IND = -5 RETURN END SUBROUTINE HC1 (IND, M, N, PR, AR, NB, S, NP1, PC, AC, VR, * VC, P, SUBR, RBUS, TOR, JR, K, IND0) C C MEANING OF THE WORK ARRAYS ... C C PC(I) = SUM OF THE IN-DEGREES OF VERTICES 1, ..., I-1 C ( PC(1) = 0 ). C AC = ADJACENCY LIST (BACKWARD). THE ELEMENTS FROM C AC(PC(I)+1) TO AC(PC(I+1)) CONTAIN, IN ANY C ORDER, ALL THE VERTICES J SUCH THAT ARC (J,I) C EXISTS. C WHEN AN ARC IS REMOVED FROM THE GRAPH AT THE K-TH LEVEL C OF THE BRANCH-DECISION TREE, THE CORRESPONDING ELEMENTS C AR(Q) AND AC(T) ARE SET TO - (K*(N+1) + AR(Q)) AND C TO - (K*(N+1) + AC(T)) , RESPECTIVELY. C VR(I) = CURRENT OUT-DEGREE OF VERTEX I . C VC(I) = CURRENT IN-DEGREE OF VERTEX I . C SUBR(I) = - (K*(N+1) + J) IF ARC (I,J) WAS IMPLIED AT C THE K-TH LEVEL OF THE BRANCH-DECISION TREE. C = 0 OTHERWISE. C RBUS(I) = - J IF ARC (J,I) IS CURRENTLY IMPLIED. C = 0 OTHERWISE. C TOR(K) = Q*(M+1) + T IF THE ARC GOING FROM S(K) TO THE C ROOT, CORRESPONDING TO AR(Q) AND TO AC(T), C WAS REMOVED FROM THE GRAPH AT THE K-TH LEVEL C OF THE BRANCH-DECISION TREE. C = 0 OTHERWISE. C P(I) = POINTER FOR THE FORWARD STEP. THE NEXT ARC C STARTING FROM I TO BE CONSIDERED IN THE C BRANCH-DECISION TREE IS (I,AR(PR(I)+P(I)). C C MEANING OF THE MAIN SIMPLE VARIABLES ... C C JR = ROOT. THE HAMILTONIAN CIRCUITS ARE DETERMINED AS C PATHS STARTING AND ENDING AT JR . C K = CURRENT LEVEL OF THE BRANCH-DECISION TREE. C IND0 = VALUE OF IND WHEN HC WAS PREVIOUSLY CALLED AND C THERE WERE NO INPUT ERRORS. C INTEGER PR(NP1), PC(NP1), AR(M), AC(M), S(N), VR(N), VC(N), * P(N), SUBR(N), RBUS(N), TOR(N) C NBO = NB NB = 0 MP1 = M + 1 IF (IND .NE. 0) GO TO 500 C C S T E P 0 (INITIALIZE). C DO 10 I=1,N VC(I) = 0 SUBR(I) = 0 RBUS(I) = 0 P(I) = 1 10 CONTINUE DO 30 I=1,N J1 = PR(I) + 1 J2 = PR(I+1) VR(I) = J2 - J1 + 1 IF (VR(I) .EQ. 0) GO TO 440 IF (VR(I) .LT. 0) GO TO 620 DO 20 J=J1,J2 JA = AR(J) VC(JA) = VC(JA) + 1 20 CONTINUE 30 CONTINUE PC(1) = 0 DO 40 I=1,N IF (VC(I) .EQ. 0) GO TO 440 PC(I+1) = PC(I) + VC(I) VC(I) = 0 40 CONTINUE DO 60 I=1,N J1 = PR(I) + 1 J2 = PR(I+1) DO 50 J=J1,J2 JJ = AR(J) VC(JJ) = VC(JJ) + 1 JA = PC(JJ) + VC(JJ) AC(JA) = I 50 CONTINUE 60 CONTINUE C SELECT AS ROOT JR THE VERTEX I WITH MAXIMUM VC(I) C (BREAK TIES BY CHOOSING I WITH MINIMUM VR(I) ). MAXE = VC(1) MINU = VR(1) JR = 1 DO 100 I=2,N IF (VC(I)-MAXE) 100, 70, 80 70 IF (VR(I).GE.MINU) GO TO 100 GO TO 90 80 MAXE = VC(I) 90 MINU = VR(I) JR = I 100 CONTINUE K1 = -NP1 K = 1 S(1) = JR C C S T E P 1 (SEARCH FOR IMPLIED ARCS). C 110 DO 120 J=1,N IF (VR(J).EQ.1) GO TO 130 IF (VC(J).EQ.1) GO TO 170 120 CONTINUE C NO FURTHER ARC CAN BE IMPLIED. GO TO 220 C ARC (J,JL) IS IMPLIED BECAUSE VR(J) = 1 . 130 L1 = PR(J) + 1 L2 = PR(J+1) DO 140 L=L1,L2 IF (AR(L).GT.0) GO TO 150 140 CONTINUE 150 JL = AR(L) C FIND THE STARTING VERTEX IT1 AND THE ENDING VERTEX IT2 C OF THE LARGEST PATH OF IMPLIED ARCS CONTAINING (J,JL) . CALL IPATH(J, JL, SUBR, RBUS, AR, PR, S, N, NP, IT1, IT2, K, JR, * M, NP1) IF (NP.EQ.0) GO TO 160 IF (NP.EQ.(-1)) GO TO 340 C SUBROUTINE IPATH FOUND A HAMILTONIAN CIRCUIT. K = K + 1 GO TO 320 160 SUBR(J) = K1 - JL RBUS(JL) = J C REMOVE FROM THE GRAPH ALL ARCS TERMINATING AT JL . CALL IUPD(J, JL, L, AC, AR, PC, PR, VC, VR, K1, N, M, NP1) IF (J.EQ.0) GO TO 340 GO TO 210 C ARC (JL,J) IS IMPLIED BECAUSE VC(J) = 1 . 170 L1 = PC(J) + 1 L2 = PC(J+1) DO 180 L=L1,L2 IF (AC(L).GT.0) GO TO 190 180 CONTINUE 190 JL = AC(L) C FIND THE STARTING VERTEX IT1 AND THE ENDING VERTEX IT2 C OF THE LARGEST PATH OF IMPLIED ARCS CONTAINING (JL,J) . CALL IPATH(JL, J, SUBR, RBUS, AR, PR, S, N, NP, IT1, IT2, K, JR, * M, NP1) IF (NP.EQ.0) GO TO 200 IF (NP.EQ.(-1)) GO TO 340 C SUBROUTINE IPATH FOUND A HAMILTONIAN CIRCUIT. I = S(K) K = K + 1 GO TO 320 200 SUBR(JL) = K1 - J RBUS(J) = JL C REMOVE FROM THE GRAPH ALL ARCS EMANATING FROM JL . CALL IUPD(J, JL, L, AR, AC, PR, PC, VR, VC, K1, N, M, NP1) IF (J.EQ.0) GO TO 340 C IF ARC (IT2,IT1) IS IN THE GRAPH, REMOVE IT. 210 CALL RARC(IT2, IT1, AR, AC, PR, PC, VR, VC, K1, JJ, LL, N, M, NP1) IF (JJ.EQ.(-1)) GO TO 340 GO TO 110 C C S T E P 2 (ADD IMPLIED ARCS TO S). C 220 I = S(K) IF (SUBR(I).EQ.0) GO TO 230 JSUBR = -SUBR(I) + (SUBR(I)/NP1)*NP1 IF (JSUBR.EQ.JR) GO TO 340 K = K + 1 S(K) = JSUBR IF (K.NE.N) GO TO 220 IF (SUBR(JSUBR).LT.0) GO TO 320 GO TO 340 C C S T E P 3 (BRANCH). C 230 L1 = PR(I) + P(I) L2 = PR(I+1) IF (L1.GT.L2) GO TO 340 C FIND THE NEXT ARC (I,JL) TO BE ADDED TO S . DENS = N**3 J1 = 0 J2 = 0 DO 310 J=L1,L2 JL = AR(J) IF (JL.LT.0) GO TO 310 IF (VR(JL).GT.0) GO TO 260 IF (SUBR(JL).EQ.0) GO TO 310 IF (JL.EQ.JR) GO TO 310 IEND = JL 240 IEND = -SUBR(IEND) + (SUBR(IEND)/NP1)*NP1 IF (SUBR(IEND).NE.0) GO TO 240 IF (VC(JL).LT.VR(IEND)) GO TO 250 SCORE = VR(IEND)*N + VC(JL) GO TO 280 250 SCORE = VC(JL)*N + VR(IEND) GO TO 280 260 IF (VC(JL).LT.VR(JL)) GO TO 270 SCORE = VR(JL)*N + VC(JL) GO TO 280 270 SCORE = VC(JL)*N + VR(JL) 280 IF (DENS.LE.SCORE) GO TO 290 DENS = SCORE IPI = J 290 IF (J1.EQ.0) GO TO 300 IF (J2.EQ.0) J2 = J GO TO 310 300 J1 = J 310 CONTINUE IF (J1.EQ.0) GO TO 340 JL = AR(IPI) AR(IPI) = AR(J1) AR(J1) = JL IF (J2.EQ.0) J2 = PR(I+1) + 1 P(I) = J2 - PR(I) K = K + 1 S(K) = JL K1 = -K*NP1 C REMOVE FROM THE GRAPH ALL ARCS EMANATING FROM I . CALL FUPD(AR, AC, PR, PC, VR, VC, I, K1, N, M, NP1) C REMOVE FROM THE GRAPH ALL ARCS TERMINATING AT JL . CALL FUPD(AC, AR, PC, PR, VC, VR, JL, K1, N, M, NP1) TOR(K) = 0 C IF ARC (JL,JR) IS IN THE GRAPH, REMOVE IT. CALL RARC(JL, JR, AR, AC, PR, PC, VR, VC, K1, JJ, LL, N, M, NP1) IF (JJ.EQ.0) GO TO 110 IF (JJ.EQ.(-1)) GO TO 340 TOR(K) = JJ*MP1 + LL GO TO 110 C C S T E P 4 (HAMILTONIAN CIRCUIT FOUND). C 320 IND = 1 IND0 = 1 K = K - 1 RETURN C C S T E P 5 (BACKTRACK). C 340 IF (K .LE. 1) GO TO 430 JA = S(K) P(JA) = 1 JA = S(K-1) IF (SUBR(JA) .EQ. 0) GO TO 350 C BACKTRACKING FOR AN IMPLIED ARC. K = K - 1 GO TO 340 350 IF (NB .EQ. NBO) GO TO 450 NB = NB + 1 K1 = -K*NP1 K2 = -(K+1)*NP1 I = S(K-1) C BACKTRACKING FOR THE ARCS IMPLIED AT LEVEL K . IFF = 0 DO 360 J=1,N IF (SUBR(J).GT.K1) GO TO 360 IF (SUBR(J).LT.K2) GO TO 360 JA = K1 - SUBR(J) RBUS(JA) = 0 SUBR(J) = 0 IFF = 1 360 CONTINUE IF (IFF.EQ.1) GO TO 370 C NO ARC WAS IMPLIED AT LEVEL K . CALL BUPD(AR, AC, PR, PC, VR, VC, I, K1, K2, N, M, NP1) CALL BUPD(AC, AR, PC, PR, VC, VR, S(K), K1, K2, N, M, NP1) IF (TOR(K).EQ.0) GO TO 420 J1 = TOR(K)/MP1 J2 = TOR(K) - J1*MP1 AR(J1) = JR JA = S(K) VR(JA) = VR(JA) + 1 AC(J2) = S(K) VC(JR) = VC(JR) + 1 GO TO 420 C AT LEAST ONE ARC WAS IMPLIED AT LEVEL K . 370 DO 410 J=1,N L1 = PR(J) + 1 L2 = PR(J+1) DO 400 L=L1,L2 JL = AR(L) IF (JL.GT.K1) GO TO 400 IF (JL.LT.K2) GO TO 400 JL = K1 - JL AR(L) = JL VR(J) = VR(J) + 1 LL1 = PC(JL) + 1 LL2 = PC(JL+1) DO 380 LL=LL1,LL2 IF (K1-AC(LL).EQ.J) GO TO 390 380 CONTINUE 390 AC(LL) = J VC(JL) = VC(JL) + 1 400 CONTINUE 410 CONTINUE 420 K = K - 1 GO TO 230 C C RESTORE THE ORIGINAL VECTOR AR C 430 DO 431 J = 1,M IF (AR(J) .GT. 0) GO TO 431 AR(J) = -AR(J) + (AR(J)/NP1)*NP1 431 CONTINUE C C THE ALGORITHM IS FINISHED C 440 IND = 4 IND0 = 4 RETURN C C THE MAXIMUM NUMBER OF BACK TRACKS WERE PERFORMED C 450 IND = 2 IND0 = 2 RETURN C C CHECK IND WHEN IND = 1, 2, OR 3 C 500 IF (IND .NE. 3) GO TO 510 IF (IND0 .EQ. 1 .OR. IND0 .EQ. 2) GO TO 430 GO TO 610 510 IF (IND .NE. IND0) GO TO 600 IF (IND .EQ. 1) GO TO 340 GO TO 350 C C ERROR RETURN C 600 IND = -2 RETURN 610 IND = -3 RETURN 620 IND = -6 RETURN END SUBROUTINE IPATH (I, J, SUBR, RBUS, AR, PR, S, N, NP, I1, I2, K, * JR, M, NP1) C C SUBROUTINE TO FIND THE STARTING VERTEX I1 AND THE ENDING C VERTEX I2 OF THE LARGEST PATH OF IMPLIED ARCS CONTAINING C ARC (I,J) . C C MEANING OF THE OUTPUT PARAMETER NP ... C C NP = 0 IF THE PATH CONTAINS L .LT. N VERTICES. C = 1 IF THE PATH CONTAINS N VERTICES AND ARC (I2,I1) C EXISTS (THE HAMILTONIAN CIRCUIT IS STORED IN S ) C = -1 IF THE PATH CONTAINS N VERTICES BUT ARC (I2,I1) C DOES NOT EXIST. C INTEGER SUBR(N), RBUS(N), AR(M), PR(NP1), S(N) C NP = 0 L = 1 I1 = I 10 IF (RBUS(I1).EQ.0) GO TO 20 I1 = RBUS(I1) L = L + 1 GO TO 10 20 I2 = J L = L + 1 30 IF (SUBR(I2).EQ.0) GO TO 40 I2 = -SUBR(I2) + (SUBR(I2)/NP1)*NP1 L = L + 1 GO TO 30 40 CONTINUE IF (L.LT.N) RETURN C THE PATH CONTAINS N VERTICES. K1 = -K*NP1 L1 = PR(I2) + 1 L2 = PR(I2+1) DO 60 L=L1,L2 IF (AR(L).LT.0) GO TO 50 IF (AR(L).EQ.I1) GO TO 70 GO TO 60 50 IF (K1-AR(L).EQ.I1) GO TO 70 60 CONTINUE C NO HAMILTONIAN CIRCUIT CAN BE DETERMINED. NP = -1 RETURN C A HAMILTONIAN CIRCUIT EXISTS. STORE IT IN S . 70 NP = 1 RBUS(J) = I RBUS(I1) = I2 S(N) = RBUS(JR) L = N - 1 80 IF (L.EQ.K) GO TO 90 JA = S(L+1) S(L) = RBUS(JA) L = L - 1 GO TO 80 90 RBUS(I1) = 0 RBUS(J) = 0 RETURN END SUBROUTINE FUPD (A1, A2, P1, P2, V1, V2, I1, K1, N, M, NP1) C C FORWARD STEP UPDATING C INTEGER A1(M), A2(M), P1(NP1), P2(NP1), V1(N), V2(N) C J1 = P1(I1) + 1 J2 = P1(I1+1) DO 30 J=J1,J2 IF (A1(J).LT.0) GO TO 30 IA = A1(J) L1 = P2(IA) + 1 L2 = P2(IA+1) DO 10 L=L1,L2 IF (A2(L).EQ.I1) GO TO 20 10 CONTINUE 20 V2(IA) = V2(IA) - 1 A2(L) = K1 - A2(L) A1(J) = K1 - IA 30 CONTINUE V1(I1) = 0 RETURN END SUBROUTINE BUPD (A1, A2, P1, P2, V1, V2, II, K1, K2, N, M, NP1) C C BACKTRACKING STEP UPDATING C INTEGER A1(M), A2(M), P1(NP1), P2(NP1), V1(N), V2(N) C L1 = P1(II) + 1 L2 = P1(II+1) DO 30 L=L1,L2 IF (A1(L).GT.K1) GO TO 30 IF (A1(L).LT.K2) GO TO 30 IA = K1 - A1(L) A1(L) = IA V1(II) = V1(II) + 1 LL1 = P2(IA) + 1 LL2 = P2(IA+1) DO 10 LL=LL1,LL2 IF (K1-A2(LL).EQ.II) GO TO 20 10 CONTINUE 20 A2(LL) = II V2(IA) = V2(IA) + 1 30 CONTINUE RETURN END SUBROUTINE IUPD(IA, IB, L, A1, A2, P1, P2, V1, V2, K1, N, M, NP1) C C UPDATING FOR IMPLIED ARC C INTEGER A1(M), A2(M), P1(NP1), P2(NP1), V1(N), V2(N) C M1 = P1(IB) + 1 M2 = P1(IB+1) DO 40 MM=M1,M2 IARC = A1(MM) IF (IARC.LT.0) GO TO 40 IF (V2(IARC).NE.1) GO TO 10 IF (IARC.NE.IA) GO TO 50 JJ = L GO TO 30 10 J1 = P2(IARC) + 1 J2 = P2(IARC+1) DO 20 JJ=J1,J2 IF (A2(JJ).EQ.IB) GO TO 30 20 CONTINUE 30 A2(JJ) = K1 - A2(JJ) V2(IARC) = V2(IARC) - 1 A1(MM) = K1 - IARC V1(IB) = V1(IB) - 1 40 CONTINUE RETURN 50 IA = 0 RETURN END SUBROUTINE RARC(IA, IB, AR, AC, PR, PC, VR, VC, K1, JJ, LL, N, M, * NP1) C C SUBROUTINE TO REMOVE ARC (IA,IB) FROM THE GRAPH. C C MEANING OF THE OUTPUT PARAMETERS JJ AND LL ... C C JJ = LOCATION OF THE ELEMENT OF AR CORRESPONDING TO THE C REMOVED ARC. C = 0 IF ARC (IA,IB) IS NOT IN THE GRAPH. C = -1 IF, AFTER THE REMOVAL OF ARC (IA,IB) , THE GRAPH C WOULD ADMIT NO HAMILTONIAN CIRCUIT. C LL = LOCATION OF THE ELEMENT OF AC CORRESPONDING TO THE C REMOVED ARC (DEFINED ONLY IF JJ .GT. 0 ). C INTEGER AR(M), AC(M), PR(NP1), PC(NP1), VR(N), VC(N) C J1 = PR(IA) + 1 J2 = PR(IA+1) DO 20 JJ=J1,J2 IF (AR(JJ).LT.0) GO TO 20 IF (AR(JJ).NE.IB) GO TO 20 L1 = PC(IB) + 1 L2 = PC(IB+1) DO 10 LL=L1,L2 IF (AC(LL).EQ.IA) GO TO 30 10 CONTINUE 20 CONTINUE C ARC (IA,IB) IS NOT IN THE GRAPH. JJ = 0 RETURN 30 IF (VR(IA).EQ.1) GO TO 40 IF (VC(IB).EQ.1) GO TO 40 AR(JJ) = K1 - IB VR(IA) = VR(IA) - 1 AC(LL) = K1 - IA VC(IB) = VC(IB) - 1 RETURN C ARC (IA,IB) CANNOT BE REMOVED FROM THE GRAPH. 40 JJ = -1 RETURN END SUBROUTINE CERF (MO, Z, W) C----------------------------------------------------------------------- C C COMPUTATION OF THE COMPLEX ERROR FUNCTION C C ---------------- C C W = ERF(Z) IF MO = 0 C W = ERFC(Z) OTHERWISE C C----------------------------------------------------------------------- COMPLEX Z, W REAL CD(18), CE(18), EF(2), QF(2), SM(2), SZ(2), TM(2), TS(2) C------------------------ C C = 1/SQRT(PI) C------------------------ DATA C /.564189583547756/ C------------------------ DATA CD(1) /0.00000000000000E00/, CD(2) /2.08605856013476E-2/, 1 CD(3) /8.29806940495687E-2/, CD(4) /1.85421653326079E-1/, 2 CD(5) /3.27963479382361E-1/, CD(6) /5.12675279912828E-1/, 3 CD(7) /7.45412958045105E-1/, CD(8) /1.03695067418297E00/, 4 CD(9) /1.40378061255437E00/, CD(10)/1.86891662214001E00/, 5 CD(11)/2.46314830523929E00/, CD(12)/3.22719383737352E00/, 6 CD(13)/4.21534348280013E00/, CD(14)/5.50178873151549E00/, 7 CD(15)/7.19258966683102E00/, CD(16)/9.45170208076408E00/, 8 CD(17)/1.25710718314784E+1/, CD(18)/1.72483537216334E+1/ DATA CE(1) /8.15723083324096E-2/, CE(2) /1.59285285253437E-1/, 1 CE(3) /1.48581625614499E-1/, CE(4) /1.33219670836245E-1/, 2 CE(5) /1.15690392878957E-1/, CE(6) /9.78580959447535E-2/, 3 CE(7) /8.05908834297624E-2/, CE(8) /6.40204538609872E-2/, 4 CE(9) /4.81445242767885E-2/, CE(10)/3.33540658473295E-2/, 5 CE(11)/2.05548099470193E-2/, CE(12)/1.07847403887506E-2/, 6 CE(13)/4.55634892214219E-3/, CE(14)/1.43984458138925E-3/, 7 CE(15)/3.07056139834171E-4/, CE(16)/3.78156541168541E-5/, 8 CE(17)/2.05173509616121E-6/, CE(18)/2.63564823682747E-8/ C------------------------ X = REAL(Z) Y = AIMAG(Z) SN = 1.0 IF (X .GE. 0.0) GO TO 10 X = -X Y = -Y SN = -1.0 C 10 R = X*X + Y*Y SZ(1) = X*X - Y*Y SZ(2) = 2.0*X*Y C IF (R .LE. 1.0) GO TO 20 IF (R .GE. 38.0) GO TO 60 IF (SZ(1) + 0.064*SZ(2)*SZ(2) .GT. 0.0) GO TO 50 C C TAYLOR SERIES C 20 C2 = C + C TM(1) = C2*X TM(2) = C2*Y SM(1) = TM(1) SM(2) = TM(2) PM = 0.0 30 PM = PM + 1.0 DM = 2.0*PM + 1.0 TS(1) = TM(1)*SZ(1) - TM(2)*SZ(2) TS(2) = TM(1)*SZ(2) + TM(2)*SZ(1) TM(1) = -TS(1)/PM TM(2) = -TS(2)/PM TS(1) = TM(1)/DM TS(2) = TM(2)/DM IF (ABS(SM(1)) + ABS(TS(1)) .NE. ABS(SM(1))) GO TO 31 IF (ABS(SM(2)) + ABS(TS(2)) .EQ. ABS(SM(2))) GO TO 40 31 SM(1) = SM(1) + TS(1) SM(2) = SM(2) + TS(2) GO TO 30 C C TERMINATION C 40 IF (MO .NE. 0) GO TO 41 W = CMPLX(SN*SM(1), SN*SM(2)) RETURN 41 IF (SN .LT. 0.0) GO TO 42 SM(1) = 0.5 + (0.5 - SM(1)) SM(2) = -SM(2) W = CMPLX(SM(1), SM(2)) RETURN 42 W = CMPLX(1.0 + SM(1), SM(2)) RETURN C C RATIONAL FUNCTION APPROXIMATION C 50 SM(1) = 0.0 SM(2) = 0.0 QM = C*EXP(-SZ(1)) TS(1) = QM*COS(-SZ(2)) TS(2) = QM*SIN(-SZ(2)) QF(1) = TS(1)*X - TS(2)*Y QF(2) = TS(1)*Y + TS(2)*X DO 51 I = 1,18 TS(1) = SZ(1) + CD(I) TS(2) = SZ(2) SS = TS(1)*TS(1) + TS(2)*TS(2) TM(1) = CE(I)*TS(1)/SS TM(2) = -CE(I)*TS(2)/SS SM(1) = SM(1) + TM(1) SM(2) = SM(2) + TM(2) 51 CONTINUE EF(1) = QF(1)*SM(1) - QF(2)*SM(2) EF(2) = QF(1)*SM(2) + QF(2)*SM(1) GO TO 100 C C ASYMPTOTIC EXPANSION C 60 QF(1) = SZ(1)/(R*R) QF(2) = -SZ(2)/(R*R) QM = C*EXP(-SZ(1)) TS(1) = QM*COS(-SZ(2)) TS(2) = QM*SIN(-SZ(2)) TM(1) = (TS(1)*X + TS(2)*Y)/R TM(2) = -(TS(1)*Y - TS(2)*X)/R SM(1) = TM(1) SM(2) = TM(2) PM = -0.5 70 PM = PM + 1.0 TS(1) = TM(1)*QF(1) - TM(2)*QF(2) TS(2) = TM(1)*QF(2) + TM(2)*QF(1) TM(1) = -PM*TS(1) TM(2) = -PM*TS(2) IF (ABS(SM(1)) + ABS(TM(1)) .NE. ABS(SM(1))) GO TO 71 IF (ABS(SM(2)) + ABS(TM(2)) .EQ. ABS(SM(2))) GO TO 80 71 SM(1) = SM(1) + TM(1) SM(2) = SM(2) + TM(2) IF (PM .LT. 25.5) GO TO 70 C 80 IF (X .GE. 0.01) GO TO 81 SN = -SN GO TO 40 81 EF(1) = SM(1) EF(2) = SM(2) C C TERMINATION C 100 IF (MO .EQ. 0) GO TO 101 W = CMPLX(EF(1), EF(2)) IF (SN .EQ. 1.0) RETURN W = CMPLX(2.0 - EF(1), -EF(2)) RETURN 101 EF(1) = SN*(1.0 - EF(1)) EF(2) = -SN*EF(2) W = CMPLX(EF(1),EF(2)) RETURN END SUBROUTINE CERFC (MO, Z, W) C----------------------------------------------------------------------- C C COMPUTATION OF THE COMPLEX COERROR FUNCTION C C ---------------- C C W = ERFC(Z) IF MO = 0 OR REAL(Z) .LT. 0 C W = EXP(X*X)*ERFC(Z) OTHERWISE C C----------------------------------------------------------------------- COMPLEX Z, W REAL CD(18), CE(18), QF(2), SM(2), SZ(2), TM(2), TS(2) C------------------------ C C = 1/SQRT(PI) C------------------------ DATA C /.564189583547756/ C------------------------ DATA CD(1) /0.00000000000000E00/, CD(2) /2.08605856013476E-2/, 1 CD(3) /8.29806940495687E-2/, CD(4) /1.85421653326079E-1/, 2 CD(5) /3.27963479382361E-1/, CD(6) /5.12675279912828E-1/, 3 CD(7) /7.45412958045105E-1/, CD(8) /1.03695067418297E00/, 4 CD(9) /1.40378061255437E00/, CD(10)/1.86891662214001E00/, 5 CD(11)/2.46314830523929E00/, CD(12)/3.22719383737352E00/, 6 CD(13)/4.21534348280013E00/, CD(14)/5.50178873151549E00/, 7 CD(15)/7.19258966683102E00/, CD(16)/9.45170208076408E00/, 8 CD(17)/1.25710718314784E+1/, CD(18)/1.72483537216334E+1/ DATA CE(1) /8.15723083324096E-2/, CE(2) /1.59285285253437E-1/, 1 CE(3) /1.48581625614499E-1/, CE(4) /1.33219670836245E-1/, 2 CE(5) /1.15690392878957E-1/, CE(6) /9.78580959447535E-2/, 3 CE(7) /8.05908834297624E-2/, CE(8) /6.40204538609872E-2/, 4 CE(9) /4.81445242767885E-2/, CE(10)/3.33540658473295E-2/, 5 CE(11)/2.05548099470193E-2/, CE(12)/1.07847403887506E-2/, 6 CE(13)/4.55634892214219E-3/, CE(14)/1.43984458138925E-3/, 7 CE(15)/3.07056139834171E-4/, CE(16)/3.78156541168541E-5/, 8 CE(17)/2.05173509616121E-6/, CE(18)/2.63564823682747E-8/ C------------------------ X = REAL(Z) Y = AIMAG(Z) SN = 1.0 IF (X .GE. 0.0) GO TO 10 X = -X Y = -Y SN = -1.0 C 10 IF (MO .NE. 0 .AND. SN .EQ. 1.0 .AND. * AMAX1(X, ABS(Y)) .GE. 100.0) GO TO 60 R = X*X + Y*Y SZ(1) = X*X - Y*Y SZ(2) = 2.0*X*Y C IF (R .LE. 1.0) GO TO 20 IF (R .GE. 38.0) GO TO 60 IF (SZ(1) + 0.064*SZ(2)*SZ(2) .GT. 0.0) GO TO 50 C C TAYLOR SERIES C 20 C2 = C + C TM(1) = C2*X TM(2) = C2*Y SM(1) = TM(1) SM(2) = TM(2) PM = 0.0 30 PM = PM + 1.0 DM = 2.0*PM + 1.0 TS(1) = TM(1)*SZ(1) - TM(2)*SZ(2) TS(2) = TM(1)*SZ(2) + TM(2)*SZ(1) TM(1) = -TS(1)/PM TM(2) = -TS(2)/PM TS(1) = TM(1)/DM TS(2) = TM(2)/DM IF (ABS(SM(1)) + ABS(TS(1)) .NE. ABS(SM(1))) GO TO 31 IF (ABS(SM(2)) + ABS(TS(2)) .EQ. ABS(SM(2))) GO TO 40 31 SM(1) = SM(1) + TS(1) SM(2) = SM(2) + TS(2) GO TO 30 C C TERMINATION C 40 IF (SN .EQ. 1.0) GO TO 41 W = CMPLX(1.0 + SM(1), SM(2)) RETURN 41 SM(1) = 0.5 + (0.5 - SM(1)) SM(2) = -SM(2) IF (MO .EQ. 0) GO TO 110 C QM = EXP(SZ(1)) QF(1) = QM*COS(SZ(2)) QF(2) = QM*SIN(SZ(2)) TS(1) = QF(1)*SM(1) - QF(2)*SM(2) TS(2) = QF(1)*SM(2) + QF(2)*SM(1) W = CMPLX(TS(1),TS(2)) RETURN C C RATIONAL FUNCTION APPROXIMATION C 50 SM(1) = 0.0 SM(2) = 0.0 DO 51 I = 1,18 TS(1) = SZ(1) + CD(I) TS(2) = SZ(2) SS = TS(1)*TS(1) + TS(2)*TS(2) TM(1) = CE(I)*TS(1)/SS TM(2) = -CE(I)*TS(2)/SS SM(1) = SM(1) + TM(1) SM(2) = SM(2) + TM(2) 51 CONTINUE TS(1) = X*SM(1) - Y*SM(2) TS(2) = X*SM(2) + Y*SM(1) SM(1) = C*TS(1) SM(2) = C*TS(2) GO TO 100 C C ASYMPTOTIC EXPANSION C 60 CALL CREC (X, Y, TM(1), TM(2)) SM(1) = TM(1) SM(2) = TM(2) QF(1) = TM(1)*TM(1) - TM(2)*TM(2) QF(2) = 2.0*TM(1)*TM(2) PM = -0.5 70 PM = PM + 1.0 TS(1) = TM(1)*QF(1) - TM(2)*QF(2) TS(2) = TM(1)*QF(2) + TM(2)*QF(1) TM(1) = -PM*TS(1) TM(2) = -PM*TS(2) IF (ABS(SM(1)) + ABS(TM(1)) .NE. ABS(SM(1))) GO TO 71 IF (ABS(SM(2)) + ABS(TM(2)) .EQ. ABS(SM(2))) GO TO 80 71 SM(1) = SM(1) + TM(1) SM(2) = SM(2) + TM(2) IF (PM .LT. 25.5) GO TO 70 80 SM(1) = C*SM(1) SM(2) = C*SM(2) IF (X .LT. 0.01) GO TO 200 C C TERMINATION C 100 IF (MO .NE. 0 .AND. SN .EQ. 1.0) GO TO 110 QM = EXP(-SZ(1)) QF(1) = QM*COS(-SZ(2)) QF(2) = QM*SIN(-SZ(2)) TS(1) = QF(1)*SM(1) - QF(2)*SM(2) TS(2) = QF(1)*SM(2) + QF(2)*SM(1) SM(1) = TS(1) SM(2) = TS(2) C IF (SN .EQ. 1.0) GO TO 110 W = CMPLX(2.0 - SM(1), -SM(2)) RETURN 110 W = CMPLX(SM(1), SM(2)) RETURN C C MODIFIED ASYMPTOTIC EXPANSION C 200 IF (MO .NE. 0 .AND. SN .EQ. 1.0) GO TO 210 QM = EXP(-SZ(1)) QF(1) = QM*COS(-SZ(2)) QF(2) = QM*SIN(-SZ(2)) TS(1) = QF(1)*SM(1) - QF(2)*SM(2) TS(2) = QF(1)*SM(2) + QF(2)*SM(1) SM(1) = 1.0 + SN*TS(1) SM(2) = SN*TS(2) W = CMPLX(SM(1),SM(2)) RETURN C 210 IF (ABS(Y) .GE. 100.0) GO TO 110 IF (SZ(1) .LE. EXPARG(1)) GO TO 110 QM = EXP(SZ(1)) SM(1) = QM*COS(SZ(2)) + SM(1) SM(2) = QM*SIN(SZ(2)) + SM(2) W = CMPLX(SM(1),SM(2)) RETURN END REAL FUNCTION ERF (X) C----------------------------------------------------------------------- C EVALUATION OF THE REAL ERROR FUNCTION C----------------------------------------------------------------------- REAL A(5),B(3),P(8),Q(8),R(5),S(4) C------------------------- DATA C /.564189583547756/ C------------------------- DATA A(1) /.771058495001320E-04/, A(2)/-.133733772997339E-02/, * A(3) /.323076579225834E-01/, A(4) /.479137145607681E-01/, * A(5) /.128379167095513E+00/ DATA B(1) /.301048631703895E-02/, B(2) /.538971687740286E-01/, * B(3) /.375795757275549E+00/ C------------------------- DATA P(1)/-1.36864857382717E-07/, P(2) /5.64195517478974E-01/, * P(3) /7.21175825088309E+00/, P(4) /4.31622272220567E+01/, * P(5) /1.52989285046940E+02/, P(6) /3.39320816734344E+02/, * P(7) /4.51918953711873E+02/, P(8) /3.00459261020162E+02/ DATA Q(1) /1.00000000000000E+00/, Q(2) /1.27827273196294E+01/, * Q(3) /7.70001529352295E+01/, Q(4) /2.77585444743988E+02/, * Q(5) /6.38980264465631E+02/, Q(6) /9.31354094850610E+02/, * Q(7) /7.90950925327898E+02/, Q(8) /3.00459260956983E+02/ C------------------------- DATA R(1) /2.10144126479064E+00/, R(2) /2.62370141675169E+01/, * R(3) /2.13688200555087E+01/, R(4) /4.65807828718470E+00/, * R(5) /2.82094791773523E-01/ DATA S(1) /9.41537750555460E+01/, S(2) /1.87114811799590E+02/, * S(3) /9.90191814623914E+01/, S(4) /1.80124575948747E+01/ C------------------------- AX = ABS(X) IF (AX .GT. 0.5) GO TO 10 T = X*X TOP = ((((A(1)*T + A(2))*T + A(3))*T + A(4))*T + A(5)) + 1.0 BOT = ((B(1)*T + B(2))*T + B(3))*T + 1.0 ERF = X*(TOP/BOT) RETURN C 10 IF (AX .GT. 4.0) GO TO 20 TOP = ((((((P(1)*AX + P(2))*AX + P(3))*AX + P(4))*AX + P(5))*AX * + P(6))*AX + P(7))*AX + P(8) BOT = ((((((Q(1)*AX + Q(2))*AX + Q(3))*AX + Q(4))*AX + Q(5))*AX * + Q(6))*AX + Q(7))*AX + Q(8) ERF = 0.5 + (0.5 - EXP(-X*X)*TOP/BOT) IF (X .LT. 0.0) ERF = -ERF RETURN C 20 IF (AX .GE. 5.8) GO TO 30 X2 = X*X T = 1.0/X2 TOP = (((R(1)*T + R(2))*T + R(3))*T + R(4))*T + R(5) BOT = (((S(1)*T + S(2))*T + S(3))*T + S(4))*T + 1.0 ERF = (C - TOP/(X2*BOT)) / AX ERF = 0.5 + (0.5 - EXP(-X2)*ERF) IF (X .LT. 0.0) ERF = -ERF RETURN C 30 ERF = SIGN(1.0,X) RETURN END REAL FUNCTION ERFC (X) C----------------------------------------------------------------------- C EVALUATION OF THE COMPLEMENTARY ERROR FUNCTION C----------------------------------------------------------------------- REAL A(5),B(3),P(8),Q(8),R(5),S(4) DOUBLE PRECISION W C------------------------- DATA C /.564189583547756/ C------------------------- DATA A(1) /.771058495001320E-04/, A(2)/-.133733772997339E-02/, * A(3) /.323076579225834E-01/, A(4) /.479137145607681E-01/, * A(5) /.128379167095513E+00/ DATA B(1) /.301048631703895E-02/, B(2) /.538971687740286E-01/, * B(3) /.375795757275549E+00/ C------------------------- DATA P(1)/-1.36864857382717E-07/, P(2) /5.64195517478974E-01/, * P(3) /7.21175825088309E+00/, P(4) /4.31622272220567E+01/, * P(5) /1.52989285046940E+02/, P(6) /3.39320816734344E+02/, * P(7) /4.51918953711873E+02/, P(8) /3.00459261020162E+02/ DATA Q(1) /1.00000000000000E+00/, Q(2) /1.27827273196294E+01/, * Q(3) /7.70001529352295E+01/, Q(4) /2.77585444743988E+02/, * Q(5) /6.38980264465631E+02/, Q(6) /9.31354094850610E+02/, * Q(7) /7.90950925327898E+02/, Q(8) /3.00459260956983E+02/ C------------------------- DATA R(1) /2.10144126479064E+00/, R(2) /2.62370141675169E+01/, * R(3) /2.13688200555087E+01/, R(4) /4.65807828718470E+00/, * R(5) /2.82094791773523E-01/ DATA S(1) /9.41537750555460E+01/, S(2) /1.87114811799590E+02/, * S(3) /9.90191814623914E+01/, S(4) /1.80124575948747E+01/ C------------------------- C C ABS(X) .LE. 0.5 C AX = ABS(X) IF (AX .GT. 0.5) GO TO 10 T = X*X TOP = ((((A(1)*T + A(2))*T + A(3))*T + A(4))*T + A(5)) + 1.0 BOT = ((B(1)*T + B(2))*T + B(3))*T + 1.0 ERFC = 0.5 + (0.5 - X*(TOP/BOT)) RETURN C C 0.5 .LT. ABS(X) .LE. 4 C 10 IF (AX .GT. 4.0) GO TO 20 TOP = ((((((P(1)*AX + P(2))*AX + P(3))*AX + P(4))*AX + P(5))*AX * + P(6))*AX + P(7))*AX + P(8) BOT = ((((((Q(1)*AX + Q(2))*AX + Q(3))*AX + Q(4))*AX + Q(5))*AX * + Q(6))*AX + Q(7))*AX + Q(8) ERFC = TOP/BOT GO TO 30 C C ABS(X) .GT. 4 C 20 IF (X .LE. -5.6) GO TO 40 IF (X .GT. 100.0) GO TO 50 T = X*X IF (T .GT. -EXPARG(1)) GO TO 50 C T = 1.0/T TOP = (((R(1)*T + R(2))*T + R(3))*T + R(4))*T + R(5) BOT = (((S(1)*T + S(2))*T + S(3))*T + S(4))*T + 1.0 ERFC = (C - T*TOP/BOT)/AX C C FINAL ASSEMBLY C 30 W = DBLE(X)*DBLE(X) T = W E = W - DBLE(T) ERFC = ((0.5 + (0.5 - E)) * EXP(-T)) * ERFC IF (X .LT. 0.0) ERFC = 2.0 - ERFC RETURN C C LIMIT VALUE FOR LARGE NEGATIVE X C 40 ERFC = 2.0 RETURN C C LIMIT VALUE FOR LARGE POSITIVE X C 50 ERFC = 0.0 RETURN END REAL FUNCTION ERFC1 (IND, X) C----------------------------------------------------------------------- C EVALUATION OF THE COMPLEMENTARY ERROR FUNCTION C C ERFC1(IND,X) = ERFC(X) IF IND = 0 C ERFC1(IND,X) = EXP(X*X)*ERFC(X) OTHERWISE C----------------------------------------------------------------------- REAL A(5),B(3),P(8),Q(8),R(5),S(4) DOUBLE PRECISION W C------------------------- DATA C /.564189583547756/ C------------------------- DATA A(1) /.771058495001320E-04/, A(2)/-.133733772997339E-02/, * A(3) /.323076579225834E-01/, A(4) /.479137145607681E-01/, * A(5) /.128379167095513E+00/ DATA B(1) /.301048631703895E-02/, B(2) /.538971687740286E-01/, * B(3) /.375795757275549E+00/ C------------------------- DATA P(1)/-1.36864857382717E-07/, P(2) /5.64195517478974E-01/, * P(3) /7.21175825088309E+00/, P(4) /4.31622272220567E+01/, * P(5) /1.52989285046940E+02/, P(6) /3.39320816734344E+02/, * P(7) /4.51918953711873E+02/, P(8) /3.00459261020162E+02/ DATA Q(1) /1.00000000000000E+00/, Q(2) /1.27827273196294E+01/, * Q(3) /7.70001529352295E+01/, Q(4) /2.77585444743988E+02/, * Q(5) /6.38980264465631E+02/, Q(6) /9.31354094850610E+02/, * Q(7) /7.90950925327898E+02/, Q(8) /3.00459260956983E+02/ C------------------------- DATA R(1) /2.10144126479064E+00/, R(2) /2.62370141675169E+01/, * R(3) /2.13688200555087E+01/, R(4) /4.65807828718470E+00/, * R(5) /2.82094791773523E-01/ DATA S(1) /9.41537750555460E+01/, S(2) /1.87114811799590E+02/, * S(3) /9.90191814623914E+01/, S(4) /1.80124575948747E+01/ C------------------------- C C ABS(X) .LE. 0.5 C AX = ABS(X) IF (AX .GT. 0.5) GO TO 10 T = X*X TOP = ((((A(1)*T + A(2))*T + A(3))*T + A(4))*T + A(5)) + 1.0 BOT = ((B(1)*T + B(2))*T + B(3))*T + 1.0 ERFC1 = 0.5 + (0.5 - X*(TOP/BOT)) IF (IND .NE. 0) ERFC1 = EXP(T) * ERFC1 RETURN C C 0.5 .LT. ABS(X) .LE. 4 C 10 IF (AX .GT. 4.0) GO TO 20 TOP = ((((((P(1)*AX + P(2))*AX + P(3))*AX + P(4))*AX + P(5))*AX * + P(6))*AX + P(7))*AX + P(8) BOT = ((((((Q(1)*AX + Q(2))*AX + Q(3))*AX + Q(4))*AX + Q(5))*AX * + Q(6))*AX + Q(7))*AX + Q(8) ERFC1 = TOP/BOT GO TO 40 C C ABS(X) .GT. 4 C 20 IF (X .LE. -5.6) GO TO 50 IF (IND .NE. 0) GO TO 30 IF (X .GT. 100.0) GO TO 60 IF (X*X .GT. -EXPARG(1)) GO TO 60 C 30 T = (1.0/X)**2 TOP = (((R(1)*T + R(2))*T + R(3))*T + R(4))*T + R(5) BOT = (((S(1)*T + S(2))*T + S(3))*T + S(4))*T + 1.0 ERFC1 = (C - T*TOP/BOT)/AX C C FINAL ASSEMBLY C 40 IF (IND .EQ. 0) GO TO 41 IF (X .LT. 0.0) ERFC1 = 2.0*EXP(X*X) - ERFC1 RETURN 41 W = DBLE(X)*DBLE(X) T = W E = W - DBLE(T) ERFC1 = ((0.5 + (0.5 - E)) * EXP(-T)) * ERFC1 IF (X .LT. 0.0) ERFC1 = 2.0 - ERFC1 RETURN C C LIMIT VALUE FOR LARGE NEGATIVE X C 50 ERFC1 = 2.0 IF (IND .NE. 0) ERFC1 = 2.0*EXP(X*X) RETURN C C LIMIT VALUE FOR LARGE POSITIVE X C WHEN IND = 0 C 60 ERFC1 = 0.0 RETURN END SUBROUTINE DCERF (MO, Z, W) C----------------------------------------------------------------------- C C COMPUTATION OF THE COMPLEX ERROR FUNCTION C C ----------------- C C W = ERF(Z) IF MO = 0 C W = ERFC(Z) OTHERWISE C C----------------------------------------------------------------------- DOUBLE PRECISION Z(2), W(2) DOUBLE PRECISION M, N, N2, N4, NP1 DOUBLE PRECISION C, C2, D, D2, E, EPS, R, SN, TOL, X, Y DOUBLE PRECISION A0(2), AN(2), B0(2), BN(2) DOUBLE PRECISION G0(2), GN(2), H0(2), HN(2) DOUBLE PRECISION QF(2), SM(2), SZ(2), TM(2), TS(2), W0(2), WN(2) DOUBLE PRECISION ANORM, DPMPAR C------------------------ ANORM(X,Y) = DMAX1(DABS(X),DABS(Y)) C------------------------ C C = 1/SQRT(PI) C------------------------ DATA C /.56418958354775628694807945156077D0/ C------------------------ C C ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE C SMALLEST NUMBER SUCH THAT 1.D0 + EPS .GT. 1.D0. C EPS = DPMPAR(1) C C------------------------ X = Z(1) Y = Z(2) SN = 1.D0 IF (X .GE. 0.D0) GO TO 10 X = -X Y = -Y SN = -1.D0 C 10 R = X*X + Y*Y SZ(1) = X*X - Y*Y SZ(2) = 2.D0*X*Y C IF (R .LE. 1.D0) GO TO 20 IF (R .GE. 144.D0) GO TO 100 IF (DABS(Y) .GT. 31.8D0*X) GO TO 50 IF (DABS(Y) .GT. 7.0D0*X .AND. R .LT. 64.D0) GO TO 50 IF (DABS(Y) .GT. 3.2D0*X .AND. R .LT. 49.D0) GO TO 50 IF (DABS(Y) .GT. 2.0D0*X .AND. R .LT. 36.D0) GO TO 50 IF (DABS(Y) .GT. 1.2D0*X .AND. R .LT. 25.D0) GO TO 50 IF (DABS(Y) .GT. 0.9D0*X .AND. R .LT. 16.D0) GO TO 50 IF (R .GE. 6.25D0) GO TO 80 IF (DABS(Y) .GT. 0.6D0*X) GO TO 50 IF (R .GE. 4.0D0) GO TO 40 C D = X - 2.D0 IF (D*D + Y*Y .LT. 1.D0) GO TO 40 GO TO 50 C C TAYLOR SERIES C 20 C2 = C + C TM(1) = C2*X TM(2) = C2*Y SM(1) = TM(1) SM(2) = TM(2) TOL = 2.D0*EPS M = 0.D0 21 M = M + 1.D0 D = M + M + 1.D0 TS(1) = TM(1)*SZ(1) - TM(2)*SZ(2) TS(2) = TM(1)*SZ(2) + TM(2)*SZ(1) TM(1) = -TS(1)/M TM(2) = -TS(2)/M TS(1) = TM(1)/D TS(2) = TM(2)/D SM(1) = SM(1) + TS(1) SM(2) = SM(2) + TS(2) IF (ANORM(TS(1),TS(2)) .GT. TOL*ANORM(SM(1),SM(2))) GO TO 21 C IF (MO .NE. 0) GO TO 30 W(1) = SN*SM(1) W(2) = SN*SM(2) RETURN 30 IF (SN .EQ. 1.D0) GO TO 31 W(1) = 1.D0 + SM(1) W(2) = SM(2) RETURN 31 W(1) = 0.5D0 + (0.5D0 - SM(1)) W(2) = -SM(2) RETURN C C TAYLOR SERIES AROUND Z0 = 2 C 40 TM(1) = X TM(2) = Y CALL ERFCM2 (0, TM, W) IF (MO .NE. 0) GO TO 41 W(1) = SN*(0.5D0 + (0.5D0 - W(1))) W(2) = - SN*W(2) RETURN 41 IF (SN .GT. 0.D0) RETURN W(1) = 2.D0 - W(1) W(2) = - W(2) RETURN C C PADE APPROXIMATION FOR THE TAYLOR SERIES C FOR (EXP(Z*Z)/Z)*ERF(Z) C 50 D = 4.D0 IF (R .GT. 16.D0) D = 16.D0 IF (R .GT. 64.D0) D = 64.D0 D2 = D*D CALL DCREC (SZ(1), SZ(2), W(1), W(2)) A0(1) = 1.D0 A0(2) = 0.D0 AN(1) = (W(1) + 4.D0/15.D0)*D AN(2) = W(2)*D B0(1) = 1.D0 B0(2) = 0.D0 BN(1) = (W(1) - 0.4D0)*D BN(2) = W(2)*D CALL CDIVID (AN(1), AN(2), BN(1), BN(2), WN(1), WN(2)) TOL = 10.D0*EPS N4 = 0.D0 C 60 N4 = N4 + 4.D0 E = (N4 + 1.D0)*(N4 + 5.D0) TM(1) = D*(W(1) - 2.D0/E) TM(2) = D*W(2) E = D2*(N4*(N4 + 2.0))/((N4 - 1.0)*(N4 + 3.0)*(N4 + 1.0)**2) C QF(1) = (TM(1)*AN(1) - TM(2)*AN(2)) + E*A0(1) QF(2) = (TM(1)*AN(2) + TM(2)*AN(1)) + E*A0(2) A0(1) = AN(1) A0(2) = AN(2) AN(1) = QF(1) AN(2) = QF(2) QF(1) = (TM(1)*BN(1) - TM(2)*BN(2)) + E*B0(1) QF(2) = (TM(1)*BN(2) + TM(2)*BN(1)) + E*B0(2) B0(1) = BN(1) B0(2) = BN(2) BN(1) = QF(1) BN(2) = QF(2) C W0(1) = WN(1) W0(2) = WN(2) CALL CDIVID (AN(1), AN(2), BN(1), BN(2), WN(1), WN(2)) IF (ANORM(WN(1) - W0(1), WN(2) - W0(2)) .GT. * TOL*ANORM(WN(1), WN(2))) GO TO 60 C C2 = C + C SM(1) = C2*(X*WN(1) - Y*WN(2)) SM(2) = C2*(X*WN(2) + Y*WN(1)) E = DEXP(-SZ(1)) QF(1) = E*DCOS(-SZ(2)) QF(2) = E*DSIN(-SZ(2)) TM(1) = QF(1)*SM(1) - QF(2)*SM(2) TM(2) = QF(1)*SM(2) + QF(2)*SM(1) C W(1) = SN*TM(1) W(2) = SN*TM(2) IF (MO .EQ. 0) RETURN W(1) = 1.D0 - W(1) W(2) = - W(2) RETURN C C PADE APPROXIMATION FOR THE ASYMPTOTIC EXPANSION C FOR Z*EXP(Z*Z)*ERFC(Z) C 80 D = 4.D0*R IF (R .LT. 16.D0) D = 16.D0*R D2 = D*D TM(1) = SZ(1) + SZ(1) TM(2) = SZ(2) + SZ(2) G0(1) = 1.D0 G0(2) = 0.D0 GN(1) = (2.D0 + TM(1))/D GN(2) = TM(2)/D H0(1) = 1.D0 H0(2) = 0.D0 TM(1) = 3.D0 + TM(1) HN(1) = TM(1)/D HN(2) = TM(2)/D CALL CDIVID (GN(1), GN(2), HN(1), HN(2), WN(1), WN(2)) NP1 = 1.D0 TOL = 10.D0*EPS C 90 N = NP1 NP1 = N + 1.D0 N2 = N + N E = (N2*(N2 + 1.D0))/D2 TM(1) = TM(1) + 4.D0 QF(1) = (TM(1)*GN(1) - TM(2)*GN(2))/D - E*G0(1) QF(2) = (TM(1)*GN(2) + TM(2)*GN(1))/D - E*G0(2) G0(1) = GN(1) G0(2) = GN(2) GN(1) = QF(1) GN(2) = QF(2) QF(1) = (TM(1)*HN(1) - TM(2)*HN(2))/D - E*H0(1) QF(2) = (TM(1)*HN(2) + TM(2)*HN(1))/D - E*H0(2) H0(1) = HN(1) H0(2) = HN(2) HN(1) = QF(1) HN(2) = QF(2) C W0(1) = WN(1) W0(2) = WN(2) CALL CDIVID (GN(1), GN(2), HN(1), HN(2), WN(1), WN(2)) IF (ANORM(WN(1) - W0(1), WN(2) - W0(2)) .GT. * TOL*ANORM(WN(1), WN(2))) GO TO 90 C TM(1) = X*HN(1) - Y*HN(2) TM(2) = X*HN(2) + Y*HN(1) CALL CDIVID (C*GN(1), C*GN(2), TM(1), TM(2), SM(1), SM(2)) GO TO 130 C C ASYMPTOTIC EXPANSION C 100 CALL DCREC (X, Y, TM(1), TM(2)) SM(1) = TM(1) SM(2) = TM(2) QF(1) = TM(1)*TM(1) - TM(2)*TM(2) QF(2) = 2.D0*TM(1)*TM(2) TOL = 2.D0*EPS D = -0.5D0 110 D = D + 1.D0 TS(1) = TM(1)*QF(1) - TM(2)*QF(2) TS(2) = TM(1)*QF(2) + TM(2)*QF(1) TM(1) = -D*TS(1) TM(2) = -D*TS(2) SM(1) = SM(1) + TM(1) SM(2) = SM(2) + TM(2) IF (ANORM(TM(1),TM(2)) .GT. TOL*ANORM(SM(1),SM(2))) GO TO 110 SM(1) = C*SM(1) SM(2) = C*SM(2) IF (X .LT. 1.D-2) GO TO 200 C C TERMINATION C 130 E = DEXP(-SZ(1)) QF(1) = E*DCOS(-SZ(2)) QF(2) = E*DSIN(-SZ(2)) TS(1) = QF(1)*SM(1) - QF(2)*SM(2) TS(2) = QF(1)*SM(2) + QF(2)*SM(1) SM(1) = TS(1) SM(2) = TS(2) C IF (MO .NE. 0) GO TO 140 W(1) = SN*(0.5D0 + (0.5D0 - SM(1))) W(2) = - SN*SM(2) RETURN 140 IF (SN .EQ. 1.D0) GO TO 141 W(1) = 2.D0 - SM(1) W(2) = -SM(2) RETURN 141 W(1) = SM(1) W(2) = SM(2) RETURN C C MODIFIED ASYMPTOTIC EXPANSION C 200 E = DEXP(-SZ(1)) QF(1) = E*DCOS(-SZ(2)) QF(2) = E*DSIN(-SZ(2)) W(1) = QF(1)*SM(1) - QF(2)*SM(2) W(2) = QF(1)*SM(2) + QF(2)*SM(1) IF (MO .EQ. 0) GO TO 210 W(1) = 1.D0 + SN*W(1) W(2) = SN*W(2) RETURN 210 IF (SN .LT. 0.0) RETURN W(1) = - W(1) W(2) = - W(2) RETURN END SUBROUTINE DCERFC (MO, Z, W) C----------------------------------------------------------------------- C C COMPUTATION OF THE COMPLEX COERROR FUNCTION C C ---------------- C C W = ERFC(Z) IF MO = 0 OR REAL(Z) .LT. 0 C W = DEXP(X*X)*ERFC(Z) OTHERWISE C C----------------------------------------------------------------------- DOUBLE PRECISION Z(2), W(2) DOUBLE PRECISION M, N, N2, N4, NP1 DOUBLE PRECISION C, C2, D, D2, E, EPS, R, SN, TOL, X, Y DOUBLE PRECISION A0(2), AN(2), B0(2), BN(2) DOUBLE PRECISION G0(2), GN(2), H0(2), HN(2) DOUBLE PRECISION QF(2), SM(2), SZ(2), TM(2), TS(2), W0(2), WN(2) DOUBLE PRECISION ANORM, DPMPAR, DXPARG C------------------------ ANORM(X,Y) = DMAX1(DABS(X),DABS(Y)) C------------------------ C C = 1/SQRT(PI) C------------------------ DATA C /.56418958354775628694807945156077D0/ C------------------------ C C ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE C SMALLEST NUMBER SUCH THAT 1.D0 + EPS .GT. 1.D0. C EPS = DPMPAR(1) C C------------------------ X = Z(1) Y = Z(2) SN = 1.D0 IF (X .GE. 0.D0) GO TO 10 X = -X Y = -Y SN = -1.D0 C 10 IF (MO .NE. 0 .AND. SN .EQ. 1.D0 .AND. * DMAX1(X, DABS(Y)) .GE. 144.D0) GO TO 100 R = X*X + Y*Y SZ(1) = X*X - Y*Y SZ(2) = 2.D0*X*Y C IF (R .LE. 1.D0) GO TO 20 IF (R .GE. 144.D0) GO TO 100 IF (DABS(Y) .GT. 31.8D0*X) GO TO 50 IF (DABS(Y) .GT. 7.0D0*X .AND. R .LT. 64.D0) GO TO 50 IF (DABS(Y) .GT. 3.2D0*X .AND. R .LT. 49.D0) GO TO 50 IF (DABS(Y) .GT. 2.0D0*X .AND. R .LT. 36.D0) GO TO 50 IF (DABS(Y) .GT. 1.2D0*X .AND. R .LT. 25.D0) GO TO 50 IF (DABS(Y) .GT. 0.9D0*X .AND. R .LT. 16.D0) GO TO 50 IF (R .GE. 6.25D0) GO TO 80 IF (DABS(Y) .GT. 0.6D0*X) GO TO 50 IF (R .GE. 4.0D0) GO TO 40 C D = X - 2.D0 IF (D*D + Y*Y .LT. 1.D0) GO TO 40 GO TO 50 C C TAYLOR SERIES C 20 C2 = C + C TM(1) = C2*X TM(2) = C2*Y SM(1) = TM(1) SM(2) = TM(2) TOL = 2.D0*EPS M = 0.D0 21 M = M + 1.D0 D = M + M + 1.D0 TS(1) = TM(1)*SZ(1) - TM(2)*SZ(2) TS(2) = TM(1)*SZ(2) + TM(2)*SZ(1) TM(1) = -TS(1)/M TM(2) = -TS(2)/M TS(1) = TM(1)/D TS(2) = TM(2)/D SM(1) = SM(1) + TS(1) SM(2) = SM(2) + TS(2) IF (ANORM(TS(1),TS(2)) .GT. TOL*ANORM(SM(1),SM(2))) GO TO 21 C IF (SN .EQ. 1.D0) GO TO 30 W(1) = 1.D0 + SM(1) W(2) = SM(2) RETURN 30 SM(1) = 0.5D0 + (0.5D0 - SM(1)) SM(2) = -SM(2) IF (MO .EQ. 0) GO TO 140 C E = DEXP(SZ(1)) QF(1) = E*DCOS(SZ(2)) QF(2) = E*DSIN(SZ(2)) W(1) = QF(1)*SM(1) - QF(2)*SM(2) W(2) = QF(1)*SM(2) + QF(2)*SM(1) RETURN C C TAYLOR SERIES AROUND Z0 = 2 C 40 IF (SN .LT. 0.D0) GO TO 41 CALL ERFCM2 (MO, Z, W) RETURN 41 TM(1) = X TM(2) = Y CALL ERFCM2 (0, TM, W) W(1) = 2.D0 - W(1) W(2) = - W(2) RETURN C C PADE APPROXIMATION FOR THE TAYLOR SERIES C FOR (EXP(Z*Z)/Z)*ERF(Z) C 50 D = 4.D0 IF (R .GT. 16.D0) D = 16.D0 IF (R .GT. 64.D0) D = 64.D0 D2 = D*D CALL DCREC (SZ(1), SZ(2), W(1), W(2)) A0(1) = 1.D0 A0(2) = 0.D0 AN(1) = (W(1) + 4.D0/15.D0)*D AN(2) = W(2)*D B0(1) = 1.D0 B0(2) = 0.D0 BN(1) = (W(1) - 0.4D0)*D BN(2) = W(2)*D CALL CDIVID (AN(1), AN(2), BN(1), BN(2), WN(1), WN(2)) TOL = 10.D0*EPS N4 = 0.D0 C 60 N4 = N4 + 4.D0 E = (N4 + 1.D0)*(N4 + 5.D0) TM(1) = D*(W(1) - 2.D0/E) TM(2) = D*W(2) E = D2*(N4*(N4 + 2.0))/((N4 - 1.0)*(N4 + 3.0)*(N4 + 1.0)**2) C QF(1) = (TM(1)*AN(1) - TM(2)*AN(2)) + E*A0(1) QF(2) = (TM(1)*AN(2) + TM(2)*AN(1)) + E*A0(2) A0(1) = AN(1) A0(2) = AN(2) AN(1) = QF(1) AN(2) = QF(2) QF(1) = (TM(1)*BN(1) - TM(2)*BN(2)) + E*B0(1) QF(2) = (TM(1)*BN(2) + TM(2)*BN(1)) + E*B0(2) B0(1) = BN(1) B0(2) = BN(2) BN(1) = QF(1) BN(2) = QF(2) C W0(1) = WN(1) W0(2) = WN(2) CALL CDIVID (AN(1), AN(2), BN(1), BN(2), WN(1), WN(2)) IF (ANORM(WN(1) - W0(1), WN(2) - W0(2)) .GT. * TOL*ANORM(WN(1), WN(2))) GO TO 60 C C2 = C + C SM(1) = C2*(X*WN(1) - Y*WN(2)) SM(2) = C2*(X*WN(2) + Y*WN(1)) C IF (MO .EQ. 0 .OR. SN .NE. 1.D0) GO TO 70 E = DEXP(SZ(1)) W(1) = E*DCOS(SZ(2)) - SM(1) W(2) = E*DSIN(SZ(2)) - SM(2) RETURN 70 E = DEXP(-SZ(1)) QF(1) = E*DCOS(-SZ(2)) QF(2) = E*DSIN(-SZ(2)) TM(1) = QF(1)*SM(1) - QF(2)*SM(2) TM(2) = QF(1)*SM(2) + QF(2)*SM(1) W(1) = 1.D0 - SN*TM(1) W(2) = - SN*TM(2) RETURN C C PADE APPROXIMATION FOR THE ASYMPTOTIC EXPANSION C FOR Z*EXP(Z*Z)*ERFC(Z) C 80 D = 4.D0*R IF (R .LT. 16.D0) D = 16.D0*R D2 = D*D TM(1) = SZ(1) + SZ(1) TM(2) = SZ(2) + SZ(2) G0(1) = 1.D0 G0(2) = 0.D0 GN(1) = (2.D0 + TM(1))/D GN(2) = TM(2)/D H0(1) = 1.D0 H0(2) = 0.D0 TM(1) = 3.D0 + TM(1) HN(1) = TM(1)/D HN(2) = TM(2)/D CALL CDIVID (GN(1), GN(2), HN(1), HN(2), WN(1), WN(2)) NP1 = 1.D0 TOL = 10.D0*EPS C 90 N = NP1 NP1 = N + 1.D0 N2 = N + N E = (N2*(N2 + 1.D0))/D2 TM(1) = TM(1) + 4.D0 QF(1) = (TM(1)*GN(1) - TM(2)*GN(2))/D - E*G0(1) QF(2) = (TM(1)*GN(2) + TM(2)*GN(1))/D - E*G0(2) G0(1) = GN(1) G0(2) = GN(2) GN(1) = QF(1) GN(2) = QF(2) QF(1) = (TM(1)*HN(1) - TM(2)*HN(2))/D - E*H0(1) QF(2) = (TM(1)*HN(2) + TM(2)*HN(1))/D - E*H0(2) H0(1) = HN(1) H0(2) = HN(2) HN(1) = QF(1) HN(2) = QF(2) C W0(1) = WN(1) W0(2) = WN(2) CALL CDIVID (GN(1), GN(2), HN(1), HN(2), WN(1), WN(2)) IF (ANORM(WN(1) - W0(1), WN(2) - W0(2)) .GT. * TOL*ANORM(WN(1), WN(2))) GO TO 90 C TM(1) = X*HN(1) - Y*HN(2) TM(2) = X*HN(2) + Y*HN(1) CALL CDIVID (C*GN(1), C*GN(2), TM(1), TM(2), SM(1), SM(2)) GO TO 130 C C ASYMPTOTIC EXPANSION C 100 CALL DCREC (X, Y, TM(1), TM(2)) SM(1) = TM(1) SM(2) = TM(2) QF(1) = TM(1)*TM(1) - TM(2)*TM(2) QF(2) = 2.D0*TM(1)*TM(2) TOL = 2.D0*EPS D = -0.5D0 110 D = D + 1.D0 TS(1) = TM(1)*QF(1) - TM(2)*QF(2) TS(2) = TM(1)*QF(2) + TM(2)*QF(1) TM(1) = -D*TS(1) TM(2) = -D*TS(2) SM(1) = SM(1) + TM(1) SM(2) = SM(2) + TM(2) IF (ANORM(TM(1),TM(2)) .GT. TOL*ANORM(SM(1),SM(2))) GO TO 110 SM(1) = C*SM(1) SM(2) = C*SM(2) IF (X .LT. 1.D-2) GO TO 200 C C TERMINATION C 130 IF (MO .NE. 0 .AND. SN .EQ. 1.D0) GO TO 140 E = DEXP(-SZ(1)) QF(1) = E*DCOS(-SZ(2)) QF(2) = E*DSIN(-SZ(2)) TS(1) = QF(1)*SM(1) - QF(2)*SM(2) TS(2) = QF(1)*SM(2) + QF(2)*SM(1) SM(1) = TS(1) SM(2) = TS(2) C IF (SN .EQ. 1.D0) GO TO 140 W(1) = 2.D0 - SM(1) W(2) = -SM(2) RETURN 140 W(1) = SM(1) W(2) = SM(2) RETURN C C MODIFIED ASYMPTOTIC EXPANSION C 200 IF (MO .NE. 0 .AND. SN .EQ. 1.D0) GO TO 210 E = DEXP(-SZ(1)) QF(1) = E*DCOS(-SZ(2)) QF(2) = E*DSIN(-SZ(2)) TS(1) = QF(1)*SM(1) - QF(2)*SM(2) TS(2) = QF(1)*SM(2) + QF(2)*SM(1) W(1) = 1.D0 + SN*TS(1) W(2) = SN*TS(2) RETURN C 210 IF (DABS(Y) .GE. 100.D0) GO TO 140 IF (SZ(1) .LE. DXPARG(1)) GO TO 140 E = DEXP(SZ(1)) W(1) = E*DCOS(SZ(2)) + SM(1) W(2) = E*DSIN(SZ(2)) + SM(2) RETURN END SUBROUTINE ERFCM2 (MO, Z, W) C----------------------------------------------------------------------- C CALCULATION OF ERFC(Z) USING THE TAYLOR SERIES C AROUND Z0 = 2 C----------------------------------------------------------------------- DOUBLE PRECISION Z(2), W(2) DOUBLE PRECISION A(63), C, E, EPS, H(2), T(2), TOL, X, Y DOUBLE PRECISION ANORM, DPMPAR C------------------------------ ANORM(X,Y) = DMAX1(DABS(X),DABS(Y)) C------------------------------ C C = (2/SQRT(PI))*EXP(-4) C E = ERFC(2) C------------------------------ DATA C /.20666985354092053857068941306585476D-01/ DATA E /.46777349810472658379307436327470714D-02/ C------------------------------ DATA A(1) / .20000000000000000000000000000000000D+01/, * A(2) / .23333333333333333333333333333333333D+01/, * A(3) / .16666666666666666666666666666666667D+01/, * A(4) / .63333333333333333333333333333333333D+00/, * A(5) /-.22222222222222222222222222222222222D-01/, * A(6) /-.16349206349206349206349206349206349D+00/, * A(7) /-.76984126984126984126984126984126984D-01/, * A(8) /-.24250440917107583774250440917107584D-02/, * A(9) / .12716049382716049382716049382716049D-01/, * A(10) / .50208433541766875100208433541766875D-02/ DATA A(11) /-.25305969750414194858639303083747528D-03/, * A(12) /-.78593217482106370995259884148773038D-03/, * A(13) /-.19118154038788959423880058800693721D-03/, * A(14) / .46324144207742091339974937858535742D-04/, * A(15) / .33885549097189308829520469732109944D-04/, * A(16) / .28637897646612243562134629672756034D-05/, * A(17) /-.29071891082127275370004560446169188D-05/, * A(18) /-.89674405786490646425523560263096103D-06/, * A(19) / .96069103941908684338469767911200105D-07/, * A(20) / .99432863129093191401848891268744113D-07/ DATA A(21) / .97610310501460621303387795457283579D-08/, * A(22) /-.65557500375673133822289344530892436D-08/, * A(23) /-.18706782059105426900361744016236561D-08/, * A(24) / .20329898993447386223176373714372370D-09/, * A(25) / .16941915827254374668448114614201210D-09/, * A(26) / .10619149520827430973786114446699534D-10/, * A(27) /-.10136148256511788733365237088810952D-10/, * A(28) /-.21042890133669970575386166675721692D-11/, * A(29) / .37186985840699828780916522245407087D-12/, * A(30) / .17921843632701679986488128324051002D-12/ DATA A(31) /-.89823991804248069863542565948598397D-16/, * A(32) /-.10533182313660970970232171410372199D-13/, * A(33) /-.12340742690978398320850088252659714D-14/, * A(34) / .44315624546581333350568244777175883D-15/, * A(35) / .11584041639989442481950487524296214D-15/, * A(36) /-.10765703619385988116658460442219647D-16/, * A(37) /-.70653158723054941879586082239984222D-17/, * A(38) /-.18708903154917138727191793341667090D-18/, * A(39) / .32549879318817103966053527398133297D-18/, * A(40) / .40654116689599228385911733319215613D-19/ DATA A(41) /-.11250074516817311101947327325293424D-19/, * A(42) /-.28923865378584966737386008432031980D-20/, * A(43) / .23653053641701517160704870522922706D-21/, * A(44) / .14665384680061888088099002254334292D-21/, * A(45) / .26971039707314316218154193225264469D-23/, * A(46) /-.58753834789274356433279671015522650D-23/, * A(47) /-.59960357240498652932299485494869633D-24/, * A(48) / .18586826578121663981412155416486531D-24/, * A(49) / .38364131854692721721867481914852428D-25/, * A(50) /-.41342210492630142578080062451711039D-26/ DATA A(51) /-.17646283105274988992381528904600860D-26/, * A(52) / .19828685934364181151988692232131608D-28/, * A(53) / .65592252170840353572672782446212733D-28/, * A(54) / .40626551379996340638338449938639730D-29/, * A(55) /-.20097984104191034713653294173834095D-29/, * A(56) /-.28104226475997460044096389060743131D-30/, * A(57) / .48705319298749358709127987806547949D-31/, * A(58) / .12664655832830787747161769929972617D-31/, * A(59) /-.75168312488894341862391776330113688D-33/, * A(60) /-.45760473722605993842481669806804415D-33/ DATA A(61) /-.56725491529575395930156379514718000D-35/, * A(62) / .13932664042920082608489441616061541D-34/, * A(63) / .10452448992516358449586503951463322D-35/ C------------------------------ C C ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE C SMALLEST NUMBER SUCH THAT 1.D0 + EPS .GT. 1.D0 C EPS = DPMPAR(1) C C------------------------------ TOL = EPS*1.D+12 H(1) = 1.D0 + (1.D0 - Z(1)) H(2) = - Z(2) C X = 1.D0 Y = 0.D0 W(1) = A(30) W(2) = 0.D0 DO 10 N = 31,63 T(1) = X*H(1) - Y*H(2) T(2) = X*H(2) + Y*H(1) X = T(1) Y = T(2) T(1) = A(N)*X T(2) = A(N)*Y W(1) = W(1) + T(1) W(2) = W(2) + T(2) IF (ANORM(T(1),T(2)) .LE. TOL*ANORM(W(1),W(2))) GO TO 20 10 CONTINUE C 20 DO 21 J = 1,29 N = 30 - J X = H(1)*W(1) - H(2)*W(2) W(2) = H(1)*W(2) + H(2)*W(1) W(1) = A(N) + X 21 CONTINUE X = H(1)*W(1) - H(2)*W(2) W(2) = H(1)*W(2) + H(2)*W(1) W(1) = 1.D0 + X C X = C*(H(1)*W(1) - H(2)*W(2)) W(2) = C*(H(1)*W(2) + H(2)*W(1)) W(1) = E + X IF (MO .EQ. 0) RETURN C C COMPUTE EXP(Z*Z)*ERFC(Z) C X = Z(1)*Z(1) - Z(2)*Z(2) Y = 2.D0*Z(1)*Z(2) X = DEXP(X) T(1) = X*DCOS(Y) T(2) = X*DSIN(Y) X = T(1)*W(1) - T(2)*W(2) Y = T(1)*W(2) + T(2)*W(1) W(1) = X W(2) = Y RETURN END DOUBLE PRECISION FUNCTION DERF (X) C----------------------------------------------------------------------- C DOUBLE PRECISION EVALUATION OF THE ERROR FUNCTION C----------------------------------------------------------------------- DOUBLE PRECISION AX, T, X, W DOUBLE PRECISION A(21) DOUBLE PRECISION DERFC0 C------------------------------- DATA A(1) / .1283791670955125738961589031215D+00/, * A(2) /-.3761263890318375246320529677070D+00/, * A(3) / .1128379167095512573896158902931D+00/, * A(4) /-.2686617064513125175943235372542D-01/, * A(5) / .5223977625442187842111812447877D-02/, * A(6) /-.8548327023450852832540164081187D-03/, * A(7) / .1205533298178966425020717182498D-03/, * A(8) /-.1492565035840625090430728526820D-04/, * A(9) / .1646211436588924261080723578109D-05/, * A(10) /-.1636584469123468757408968429674D-06/ DATA A(11) / .1480719281587021715400818627811D-07/, * A(12) /-.1229055530145120140800510155331D-08/, * A(13) / .9422759058437197017313055084212D-10/, * A(14) /-.6711366740969385085896257227159D-11/, * A(15) / .4463222608295664017461758843550D-12/, * A(16) /-.2783497395542995487275065856998D-13/, * A(17) / .1634095572365337143933023780777D-14/, * A(18) /-.9052845786901123985710019387938D-16/, * A(19) / .4708274559689744439341671426731D-17/, * A(20) /-.2187159356685015949749948252160D-18/, * A(21) / .7043407712019701609635599701333D-20/ C------------------------------- C C DABS(X) .LE. 1 C AX = DABS(X) IF (AX .GT. 1.D0) GO TO 20 T = X*X W = A(21) DO 10 I = 1,20 K = 21 - I W = T*W + A(K) 10 CONTINUE DERF = X*(1.D0 + W) RETURN C C DABS(X) .GT. 1 C 20 IF (AX .GE. 8.5D0) GO TO 30 DERF = 0.5D0 + (0.5D0 - DEXP(-X*X)*DERFC0(AX)) IF (X .LT. 0.D0) DERF = -DERF RETURN C C LIMIT VALUE FOR LARGE X C 30 DERF = DSIGN(1.D0,X) RETURN END DOUBLE PRECISION FUNCTION DERFC (X) C----------------------------------------------------------------------- C EVALUATION OF THE COMPLEMENTARY ERROR FUNCTION C----------------------------------------------------------------------- DOUBLE PRECISION X, AX, T, W DOUBLE PRECISION A(21) DOUBLE PRECISION DERFC0, DXPARG C------------------------------- DATA A(1) / .1283791670955125738961589031215D+00/, * A(2) /-.3761263890318375246320529677070D+00/, * A(3) / .1128379167095512573896158902931D+00/, * A(4) /-.2686617064513125175943235372542D-01/, * A(5) / .5223977625442187842111812447877D-02/, * A(6) /-.8548327023450852832540164081187D-03/, * A(7) / .1205533298178966425020717182498D-03/, * A(8) /-.1492565035840625090430728526820D-04/, * A(9) / .1646211436588924261080723578109D-05/, * A(10) /-.1636584469123468757408968429674D-06/ DATA A(11) / .1480719281587021715400818627811D-07/, * A(12) /-.1229055530145120140800510155331D-08/, * A(13) / .9422759058437197017313055084212D-10/, * A(14) /-.6711366740969385085896257227159D-11/, * A(15) / .4463222608295664017461758843550D-12/, * A(16) /-.2783497395542995487275065856998D-13/, * A(17) / .1634095572365337143933023780777D-14/, * A(18) /-.9052845786901123985710019387938D-16/, * A(19) / .4708274559689744439341671426731D-17/, * A(20) /-.2187159356685015949749948252160D-18/, * A(21) / .7043407712019701609635599701333D-20/ C------------------------------- C C DABS(X) .LE. 1 C AX = DABS(X) IF (AX .GT. 1.D0) GO TO 20 T = X*X W = A(21) DO 10 I = 1,20 K = 21 - I W = T*W + A(K) 10 CONTINUE DERFC = 0.5D0 + (0.5D0 - X*(1.D0 + W)) RETURN C C X .LT. -1 C 20 IF (X .GT. 0.D0) GO TO 30 DERFC = 2.D0 IF (X .LT. -8.3D0) RETURN T = X*X DERFC = 2.D0 - DEXP(-T) * DERFC0(AX) RETURN C C X .GT. 1 C 30 DERFC = 0.D0 IF (X .GT. 100.D0) RETURN T = X*X IF (T .GT. -DXPARG(1)) RETURN DERFC = DEXP(-T) * DERFC0(X) RETURN END DOUBLE PRECISION FUNCTION DERFC1 (IND, X) C----------------------------------------------------------------------- C C EVALUATION OF THE COMPLEMENTARY ERROR FUNCTION C C DERFC1(IND,X) = ERFC(X) IF IND = 0 C DERFC1(IND,X) = EXP(X*X)*ERFC(X) OTHERWISE C C----------------------------------------------------------------------- DOUBLE PRECISION X, AX, T, W DOUBLE PRECISION A(21) DOUBLE PRECISION DERFC0, DXPARG C------------------------------- DATA A(1) / .1283791670955125738961589031215D+00/, * A(2) /-.3761263890318375246320529677070D+00/, * A(3) / .1128379167095512573896158902931D+00/, * A(4) /-.2686617064513125175943235372542D-01/, * A(5) / .5223977625442187842111812447877D-02/, * A(6) /-.8548327023450852832540164081187D-03/, * A(7) / .1205533298178966425020717182498D-03/, * A(8) /-.1492565035840625090430728526820D-04/, * A(9) / .1646211436588924261080723578109D-05/, * A(10) /-.1636584469123468757408968429674D-06/ DATA A(11) / .1480719281587021715400818627811D-07/, * A(12) /-.1229055530145120140800510155331D-08/, * A(13) / .9422759058437197017313055084212D-10/, * A(14) /-.6711366740969385085896257227159D-11/, * A(15) / .4463222608295664017461758843550D-12/, * A(16) /-.2783497395542995487275065856998D-13/, * A(17) / .1634095572365337143933023780777D-14/, * A(18) /-.9052845786901123985710019387938D-16/, * A(19) / .4708274559689744439341671426731D-17/, * A(20) /-.2187159356685015949749948252160D-18/, * A(21) / .7043407712019701609635599701333D-20/ C------------------------------- C C DABS(X) .LE. 1 C AX = DABS(X) IF (AX .GT. 1.D0) GO TO 20 T = X*X W = A(21) DO 10 I = 1,20 K = 21 - I W = T*W + A(K) 10 CONTINUE DERFC1 = 0.5D0 + (0.5D0 - X*(1.D0 + W)) IF (IND .NE. 0) DERFC1 = DEXP(T) * DERFC1 RETURN C C X .LT. -1 C 20 IF (X .GT. 0.D0) GO TO 50 IF (X .LT. -8.3D0) GO TO 80 IF (IND .EQ. 0) GO TO 30 DERFC1 = 2.D0*DEXP(X*X) - DERFC0(AX) RETURN 30 DERFC1 = 2.D0 - DEXP(-X*X)*DERFC0(AX) RETURN C C X .GT. 1 C 50 IF (IND .EQ. 0) GO TO 60 DERFC1 = DERFC0(X) RETURN 60 DERFC1 = 0.D0 IF (X .GT. 100.D0) RETURN T = X*X IF (T .GT. -DXPARG(1)) RETURN DERFC1 = DEXP(-T) * DERFC0(X) RETURN C C LIMIT VALUE FOR LARGE NEGATIVE X C 80 DERFC1 = 2.D0 IF (IND .NE. 0) DERFC1 = 2.D0*DEXP(X*X) RETURN END DOUBLE PRECISION FUNCTION DERFC0 (X) C----------------------------------------------------------------------- C C EVALUATION OF EXP(X**2)*ERFC(X) FOR X .GE. 1 C C----------------------------------------------------------------------- C WRITTEN BY ALFRED H. MORRIS, JR. C NAVAL SURFACE WARFARE CENTER C DAHLGREN, VIRGINIA C APRIL 1992 C------------------------------- DOUBLE PRECISION X, T, U, V, Z, RPINV DOUBLE PRECISION P0, P1, P2, P3, P4, P5, P6, P7, * Q1, Q2, Q3, Q4, Q5, Q6, Q7 DOUBLE PRECISION R0, R1, R2, R3, R4, R5, R6, R7, R8 DOUBLE PRECISION A0, A1, A2, A3, A4, A5, A6, A7, A8, * B1, B2, B3, B4, B5, B6, B7, B8, B9, * B10, B11 DOUBLE PRECISION C0, C1, C2, C3, C4, C5, C6, C7, C8, * D1, D2, D3, D4, D5, D6, D7, D8, D9 DOUBLE PRECISION E0, E1, E2, E3 DOUBLE PRECISION S1, S2, S3, S4, S5, S6, S7, S8, S9, * S10, S11 C------------------------------- C RPINV = 1/SQRT(PI) C------------------------------- DATA RPINV /.56418958354775628694807945156077259D0/ C------------------------------- DATA P0 / .16506148041280876191828601D-03/, * P1 / .15471455377139313353998665D-03/, * P2 / .44852548090298868465196794D-04/, * P3 /-.49177280017226285450486205D-05/, * P4 /-.69353602078656412367801676D-05/, * P5 /-.20508667787746282746857743D-05/, * P6 /-.28982842617824971177267380D-06/, * P7 /-.17272433544836633301127174D-07/ DATA Q1 /.16272656776533322859856317D+01/, * Q2 /.12040996037066026106794322D+01/, * Q3 /.52400246352158386907601472D+00/, * Q4 /.14497345252798672362384241D+00/, * Q5 /.25592517111042546492590736D-01/, * Q6 /.26869088293991371028123158D-02/, * Q7 /.13133767840925681614496481D-03/ C------------------------------- DATA R0 / .145589721275038539045668824025D+00/, * R1 /-.273421931495426482902320421863D+00/, * R2 / .226008066916621506788789064272D+00/, * R3 /-.163571895523923805648814425592D+00/, * R4 / .102604312032193978662297299832D+00/, * R5 /-.548023266949835519254211506880D-01/, * R6 / .241432239725390106956523668160D-01/, * R7 /-.822062115403915116036874169600D-02/, * R8 / .180296241564687154310619200000D-02/ C------------------------------- DATA A0 /-.45894433406309678202825375D-03/, * A1 /-.12281298722544724287816236D-01/, * A2 /-.91144359512342900801764781D-01/, * A3 /-.28412489223839285652511367D-01/, * A4 / .14083827189977123530129812D+01/, * A5 / .11532175281537044570477189D+01/, * A6 /-.72170903389442152112483632D+01/, * A7 /-.19685597805218214001309225D+01/, * A8 / .93846891504541841150916038D+01/ DATA B1 / .25136329960926527692263725D+02/, * B2 / .15349442087145759184067981D+03/, * B3 /-.29971215958498680905476402D+03/, * B4 /-.33876477506888115226730368D+04/, * B5 / .28301829314924804988873701D+04/, * B6 / .22979620942196507068034887D+05/, * B7 /-.24280681522998071562462041D+05/, * B8 /-.36680620673264731899504580D+05/, * B9 / .42278731622295627627042436D+05/, * B10/ .28834257644413614344549790D+03/, * B11/ .70226293775648358646587341D+03/ C------------------------------- DATA C0 /-.7040906288250128001000086D-04/, * C1 /-.3858822461760510359506941D-02/, * C2 /-.7708202127512212359395078D-01/, * C3 /-.6713655014557429480440263D+00/, * C4 /-.2081992124162995545731882D+01/, * C5 / .2898831421475282558867888D+01/, * C6 / .2199509380600429331650192D+02/, * C7 / .2907064664404115316722996D+01/, * C8 /-.4766208741588182425380950D+02/ DATA D1 / .5238852785508439144747174D+02/, * D2 / .9646843357714742409535148D+03/, * D3 / .7007152775135939601804416D+04/, * D4 / .8515386792259821780601162D+04/, * D5 /-.1002360095177164564992134D+06/, * D6 /-.2065250031331232815791912D+06/, * D7 / .5695324805290370358175984D+06/, * D8 / .6589752493461331195697873D+06/, * D9 /-.1192930193156561957631462D+07/ C------------------------------- DATA E0 / .540464821348814822409610122136D+00/, * E1 /-.261515522487415653487049835220D-01/, * E2 /-.288573438386338758794591212600D-02/, * E3 /-.529353396945788057720258856000D-03/ C------------------------------- C COEFFICIENTS FOR THE ASYMPTOTIC EXPANSION C------------------------------- DATA S1 / .75000000000000000000D+00/, * S2 /-.18750000000000000000D+01/, * S3 / .65625000000000000000D+01/, * S4 /-.29531250000000000000D+02/, * S5 / .16242187500000000000D+03/, * S6 /-.10557421875000000000D+04/, * S7 / .79180664062500000000D+04/, * S8 /-.67303564453125000000D+05/, * S9 / .63938386230468750000D+06/, * S10 /-.67135305541992187500D+07/, * S11 / .77205601373291015625D+08/ C------------------------------- C C 1 .LE. X .LE. 2 C IF (X .GT. 2.D0) GO TO 10 U = ((((((P7*X + P6)*X + P5)*X + P4)*X + P3)*X + * P2)*X + P1)*X + P0 V = ((((((Q7*X + Q6)*X + Q5)*X + Q4)*X + Q3)*X + * Q2)*X + Q1)*X + 1.D0 C T = (X - 3.75D0)/(X + 3.75D0) DERFC0 = (((((((((U/V)*T + R8)*T + R7)*T + R6)*T + R5)*T + * R4)*T + R3)*T + R2)*T + R1)*T + R0 RETURN C C 2 .LT. X .LE. 4 C 10 IF (X .GT. 4.D0) GO TO 20 Z = 1.D0/(2.5D0 + X*X) U = (((((((A8*Z + A7)*Z + A6)*Z + A5)*Z + A4)*Z + A3)*Z + * A2)*Z + A1)*Z + A0 V = ((((((((((B11*Z + B10)*Z + B9)*Z + B8)*Z + B7)*Z + B6)*Z + * B5)*Z + B4)*Z + B3)*Z + B2)*Z + B1)*Z + 1.D0 C T = 13.D0*Z - 1.D0 DERFC0 = ((((U/V)*T + E2)*T + E1)*T + E0)/X RETURN C C 4 .LT. X .LT. 50 C 20 IF (X .GE. 50.D0) GO TO 30 Z = 1.D0/(2.5D0 + X*X) U = (((((((C8*Z + C7)*Z + C6)*Z + C5)*Z + C4)*Z + C3)*Z + * C2)*Z + C1)*Z + C0 V = ((((((((D9*Z + D8)*Z + D7)*Z + D6)*Z + D5)*Z + D4)*Z + * D3)*Z + D2)*Z + D1)*Z + 1.D0 C T = 13.D0*Z - 1.D0 DERFC0 = (((((U/V)*T + E3)*T + E2)*T + E1)*T + E0)/X RETURN C C X .GE. 50 C 30 T = (1.D0/X)**2 Z = (((((((((((S11*T + S10)*T + S9)*T + S8)*T + S7)*T + * S6)*T + S5)*T + S4)*T + S3)*T + S2)*T + S1)*T - * 0.5D0)*T + 1.D0 DERFC0 = RPINV*(Z/X) RETURN END REAL FUNCTION ERFI (P, Q) C----------------------------------------------------------------------- C C EVALUATION OF THE INVERSE ERROR FUNCTION C C --------------- C C FOR 0 .LE. P .LT. 1, W = ERFI(P,Q) WHERE ERF(W) = P. IT IS C ASSUMED THAT Q = 1 - P. IF P .LT. 0, Q .LE. 0, OR P + Q IS C NOT 1, THEN ERFI(P,Q) IS SET TO A NEGATIVE VALUE. C C----------------------------------------------------------------------- C REFERENCE. MATHEMATICS OF COMPUTATION,OCT.1976,PP.827-830. C J.M.BLAIR,C.A.EDWARDS,J.H.JOHNSON C----------------------------------------------------------------------- REAL A(6),B(6),A1(7),B1(7),A2(9),B2(8),A3(9),B3(6) C----------------------------------------------------------------------- C C2 = LN(1.E-100) C----------------------------------------------------------------------- DATA C /.5625/, C1 /.87890625/ DATA C2 /-.2302585092994046E+03/ C----------------------------------------------------------------------- C TABLE NO.16 C----------------------------------------------------------------------- DATA A(1)/.1400216916161353E+03/, A(2)/-.7204275515686407E+03/, 1 A(3)/.1296708621660511E+04/, A(4)/-.9697932901514031E+03/, 2 A(5)/.2762427049269425E+03/, A(6)/-.2012940180552054E+02/ DATA B(1)/.1291046303114685E+03/, B(2)/-.7312308064260973E+03/, 1 B(3)/.1494970492915789E+04/, B(4)/-.1337793793683419E+04/, 2 B(5)/.5033747142783567E+03/, B(6)/-.6220205554529216E+02/ C----------------------------------------------------------------------- C TABLE NO.36 C----------------------------------------------------------------------- DATA A1(1)/-.1690478046781745E+00/, A1(2)/.3524374318100228E+01/, 1 A1(3)/-.2698143370550352E+02/, A1(4)/.9340783041018743E+02/, 2 A1(5)/-.1455364428646732E+03/, A1(6)/.8805852004723659E+02/, 3 A1(7)/-.1349018591231947E+02/ DATA B1(1)/-.1203221171313429E+00/, B1(2)/.2684812231556632E+01/, 1 B1(3)/-.2242485268704865E+02/, B1(4)/.8723495028643494E+02/, 2 B1(5)/-.1604352408444319E+03/, B1(6)/.1259117982101525E+03/, 3 B1(7)/-.3184861786248824E+02/ C----------------------------------------------------------------------- C TABLE NO.56 C----------------------------------------------------------------------- DATA A2(1)/.3100808562552958E-04/, A2(2)/.4097487603011940E-02/, 1 A2(3)/.1214902662897276E+00/, A2(4)/.1109167694639028E+01/, 2 A2(5)/.3228379855663924E+01/, A2(6)/.2881691815651599E+01/, 3 A2(7)/.2047972087262996E+01/, A2(8)/.8545922081972148E+00/, 4 A2(9)/.3551095884622383E-02/ DATA B2(1)/.3100809298564522E-04/, B2(2)/.4097528678663915E-02/, 1 B2(3)/.1215907800748757E+00/, B2(4)/.1118627167631696E+01/, 2 B2(5)/.3432363984305290E+01/, B2(6)/.4140284677116202E+01/, 3 B2(7)/.4119797271272204E+01/, B2(8)/.2162961962641435E+01/ C----------------------------------------------------------------------- C TABLE NO.79 C----------------------------------------------------------------------- DATA A3(1)/.3205405422062050E-08/, A3(2)/.1899479322632128E-05/, 1 A3(3)/.2814223189858532E-03/, A3(4)/.1370504879067817E-01/, 2 A3(5)/.2268143542005976E+00/, A3(6)/.1098421959892340E+01/, 3 A3(7)/.6791143397056208E+00/, A3(8)/-.834334189167721E+00/, 4 A3(9)/.3421951267240343E+00/ DATA B3(1)/.3205405053282398E-08/, B3(2)/.1899480592260143E-05/, 1 B3(3)/.2814349691098940E-03/, B3(4)/.1371092249602266E-01/, 2 B3(5)/.2275172815174473E+00/, B3(6)/.1125348514036959E+01/ C----------------------------------------------------------------------- IF (P .LT. 0.0 .OR. Q .LE. 0.0) GO TO 100 EPS = AMAX1(SPMPAR(1),1.E-15) T = 0.5 + (0.5 - (P + Q)) IF (ABS(T) .GT. 3.0*EPS) GO TO 110 C C 0 .LE. P .LE. 0.75 C IF (P .GT. 0.75) GO TO 10 V = P*P - C T = P * (((((A(6)*V + A(5))*V + A(4))*V + A(3))*V * + A(2))*V + A(1)) S = (((((V + B(6))*V + B(5))*V + B(4))*V + B(3))*V * + B(2))*V + B(1) GO TO 40 C C 0.75 .LT. P .LE. 0.9375 C 10 IF (P .GT. 0.9375) GO TO 20 V = P*P - C1 T = P * ((((((A1(7)*V + A1(6))*V + A1(5))*V + A1(4))*V * + A1(3))*V + A1(2))*V + A1(1)) S = ((((((V + B1(7))*V + B1(6))*V + B1(5))*V + B1(4))*V * + B1(3))*V + B1(2))*V + B1(1) GO TO 40 C C 1.E-100 .LE. Q .LT. 0.0625 C 20 V1 = ALOG(Q) V = 1.0/SQRT(-V1) IF (V1 .LT. C2) GO TO 30 T = (((((((A2(9)*V + A2(8))*V + A2(7))*V + A2(6))*V + A2(5))*V * + A2(4))*V + A2(3))*V + A2(2))*V + A2(1) S = V * ((((((((V + B2(8))*V + B2(7))*V + B2(6))*V + B2(5))*V * + B2(4))*V + B2(3))*V + B2(2))*V + B2(1)) GO TO 40 C C 1.E-10000 .LE. Q .LT. 1.E-100 C 30 T = (((((((A3(9)*V + A3(8))*V + A3(7))*V + A3(6))*V + A3(5))*V * + A3(4))*V + A3(3))*V + A3(2))*V + A3(1) S = V * ((((((V + B3(6))*V + B3(5))*V + B3(4))*V + B3(3))*V * + B3(2))*V + B3(1)) 40 ERFI = T/S RETURN C C ERROR RETURN C 100 ERFI = -1.0 RETURN 110 ERFI = -2.0 RETURN END DOUBLE PRECISION FUNCTION DERFI (P, Q) C----------------------------------------------------------------------- C C DOUBLE PRECISION COMPUTATION OF C THE INVERSE ERROR FUNCTION C C ---------------- C C FOR 0 .LE. P .LE. 1, W = DERFI(P,Q) WHERE ERF(W) = P. IT C IS ASSUMED THAT Q = 1 - P. IF P .LT. 0, Q .LE. 0, OR P + Q C IS NOT 1, THEN DERFI(P,Q) IS SET TO A NEGATIVE VALUE. C C----------------------------------------------------------------------- C REFERENCE. MATHEMATICS OF COMPUTATION,OCT.1976,PP.827-830. C J.M.BLAIR,C.A.EDWARDS,J.H.JOHNSON C----------------------------------------------------------------------- DOUBLE PRECISION P, Q DOUBLE PRECISION C, C1, C2, R, EPS, F, LNQ, S, T, X DOUBLE PRECISION A(7), A1(7), A2(7), A3(11), A4(9), * B(7), B1(6), B2(6), B3(10), B4(9) DOUBLE PRECISION DPMPAR, DERF, DERFC1 C----------------------------------------------------------------------- C C2 = LN(1.E-100) C R = SQRT(PI)/2 C----------------------------------------------------------------------- DATA C /.5625D0/, C1 /.87890625D0/ DATA C2 /-.2302585092994045684017991454684364D+03/ DATA R /.8862269254527580136490837416705726D+00/ C----------------------- DATA A(1)/.841467547194693616D-01/, A(2)/.160499904248262200D+01/, * A(3)/.809451641478547505D+01/, A(4)/.164273396973002581D+02/, * A(5)/.154297507839223692D+02/, A(6)/.669584134660994039D+01/, * A(7)/.108455979679682472D+01/ DATA B(1)/.352281538790042405D-02/, B(2)/.293409069065309557D+00/, * B(3)/.326709873508963100D+01/, B(4)/.123611641257633210D+02/, * B(5)/.207984023857547070D+02/, B(6)/.170791197367677668D+02/, * B(7)/.669253523595376683D+01/ C----------------------- DATA A1(1)/.552755110179178015D+2/, A1(2)/.657347545992519152D+3/, * A1(3)/.124276851197202733D+4/, A1(4)/.818859792456464820D+3/, * A1(5)/.234425632359410093D+3/, A1(6)/.299942187305427917D+2/, * A1(7)/.140496035731853946D+1/ DATA B1(1)/.179209835890172156D+3/, B1(2)/.991315839349539886D+3/, * B1(3)/.138271033653003487D+4/, B1(4)/.764020340925985926D+3/, * B1(5)/.194354053300991923D+3/, B1(6)/.228139510050586581D+2/ C----------------------- DATA A2(1)/.500926197430588206D+1/, A2(2)/.111349802614499199D+3/, * A2(3)/.353872732756132161D+3/, A2(4)/.356000407341490731D+3/, * A2(5)/.143264457509959760D+3/, A2(6)/.240823237485307567D+2/, * A2(7)/.140496035273226366D+1/ DATA B2(1)/.209004294324106981D+2/, B2(2)/.198607335199741185D+3/, * B2(3)/.439311287748524270D+3/, B2(4)/.355415991280861051D+3/, * B2(5)/.123303672628828521D+3/, B2(6)/.186060775181898848D+2/ C----------------------------------------------------------------------- C MODIFIED TABLE NO.59 C----------------------------------------------------------------------- DATA A3(1) /.237121026548776092D4/, A3(2) /.732899958728969905D6/, * A3(3) /.182063754893444775D7/, A3(4) /.269191299062422172D7/, * A3(5) /.304817224671614253D7/, A3(6) /.130643103351072345D7/, * A3(7) /.296799076241952125D6/, A3(8) /.457006532030955554D5/, * A3(9) /.373449801680687213D4/, A3(10)/.118062255483596543D3/, * A3(11)/.100000329157954960D1/ DATA B3(1) /.851911109952055378D6/, B3(2) /.194746720192729966D7/, * B3(3) /.373640079258593694D7/, B3(4) /.397271370110424145D7/, * B3(5) /.339457682064283712D7/, B3(6) /.136888294898155938D7/, * B3(7) /.303357770911491406D6/, B3(8) /.459721480357533823D5/, * B3(9) /.373762573565814355D4/, B3(10)/.118064334590001264D3/ C----------------------------------------------------------------------- C MODIFIED TABLE NO.82 C----------------------------------------------------------------------- DATA A4(1)/.154269429680540807D12/, A4(2)/.430207405012067454D12/, * A4(3)/.182623446525965017D12/, A4(4)/.248740194409838713D11/, * A4(5)/.133506080294978121D10/, A4(6)/.302446226073105850D08/, * A4(7)/.285909602878724425D06/, A4(8)/.101789226017835707D04/, * A4(9)/.100000004821118676D01/ DATA B4(1)/.220533001293836387D12/, B4(2)/.347822938010402687D12/, * B4(3)/.468373326975152250D12/, B4(4)/.185251723580351631D12/, * B4(5)/.249464490520921771D11/, B4(6)/.133587491840784926D10/, * B4(7)/.302480682561295591D08/, B4(8)/.285913799407861384D06/, * B4(9)/.101789250893050230D04/ C----------------------------------------------------------------------- IF (P .LT. 0.D0 .OR. Q .LE. 0.D0) GO TO 100 EPS = DPMPAR(1) T = 0.5D0 + (0.5D0 - (P + Q)) IF (DABS(T) .GT. 3.D0*EPS) GO TO 110 C C 0 .LE. P .LE. 0.75 C IF (P .GT. 0.75D0) GO TO 10 X = C - P*P S = (((((A(1)*X + A(2))*X + A(3))*X + A(4))*X + A(5))*X * + A(6))*X + A(7) T = ((((((B(1)*X + B(2))*X + B(3))*X + B(4))*X + B(5))*X * + B(6))*X + B(7))*X + 1.D0 DERFI = P*(S/T) IF (EPS .GT. 1.D-19) RETURN C X = DERFI F = DERF(X) - P DERFI = X - R * DEXP(X*X) * F RETURN C C 0.75 .LT. P .LE. 0.9375 C 10 IF (P .GT. 0.9375D0) GO TO 40 X = C1 - P*P IF (X .GT. 0.1D0) GO TO 20 S = ((((((A1(1)*X + A1(2))*X + A1(3))*X + A1(4))*X * + A1(5))*X + A1(6))*X + A1(7)) T = ((((((B1(1)*X + B1(2))*X + B1(3))*X + B1(4))*X * + B1(5))*X + B1(6))*X + 1.D0) GO TO 30 C 20 S = ((((((A2(1)*X + A2(2))*X + A2(3))*X + A2(4))*X * + A2(5))*X + A2(6))*X + A2(7)) T = ((((((B2(1)*X + B2(2))*X + B2(3))*X + B2(4))*X * + B2(5))*X + B2(6))*X + 1.D0) C 30 DERFI = P*(S/T) IF (EPS .GT. 1.D-19) RETURN C X = DERFI T = DERFC1(1,X) - DEXP(X*X)*Q DERFI = X + R * T RETURN C C 1.E-100 .LE. Q .LT. 0.0625 C 40 LNQ = DLOG(Q) X = 1.D0/DSQRT(- LNQ) IF (LNQ .LT. C2) GO TO 50 S = (((((((((A3(1)*X + A3(2))*X + A3(3))*X + A3(4))*X + A3(5))*X * + A3(6))*X + A3(7))*X + A3(8))*X + A3(9))*X * + A3(10))*X + A3(11) T = (((((((((B3(1)*X + B3(2))*X + B3(3))*X + B3(4))*X + B3(5))*X * + B3(6))*X + B3(7))*X + B3(8))*X + B3(9))*X * + B3(10))*X + 1.D0 GO TO 60 C C 1.E-10000 .LE. Q .LT. 1.E-100 C 50 S = (((((((A4(1)*X + A4(2))*X + A4(3))*X + A4(4))*X + A4(5))*X * + A4(6))*X + A4(7))*X + A4(8))*X + A4(9) T = ((((((((B4(1)*X + B4(2))*X + B4(3))*X + B4(4))*X + B4(5))*X * + B4(6))*X + B4(7))*X + B4(8))*X + B4(9))*X + 1.D0 C 60 DERFI = S/(X*T) IF (EPS .GT. 5.D-20) RETURN C X = DERFI T = DERFC1(1,X) F = (DLOG(T) - LNQ) - X*X DERFI = X + R*T*F RETURN C C ERROR RETURN C 100 DERFI = -1.D0 RETURN 110 DERFI = -2.D0 RETURN END REAL FUNCTION AERF (X, H) C----------------------------------------------------------------------- C COMPUTATION OF ERF(X + H) - ERF(X - H) C----------------------------------------------------------------------- C C = 2/SQRT(PI) C P = LN(9*SQRT(PI)) C--------------------- DATA C /1.12837916709551257/, P /2.76959/ C--------------------- C C **** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE C SMALLEST NUMBER SUCH THAT 1.0 + EPS .GT. 1.0 . C EPS = SPMPAR(1) C C--------------------- AERF = 0.0 IF (H .EQ. 0.0) RETURN C AH = ABS(H) AX = ABS(X) XPH = AX + AH XMH = AX - AH C T = AMAX1(AH,AX) T = T*T IF (1.6*T*T .LT. EPS) GO TO 140 IF ((AX*AH)**2 .LT. 0.5*EPS) GO TO 150 IF (AX .LE. AH) GO TO 100 C IF (XMH .LT. 9.0) GO TO 5 IF (XMH*XMH + P .GT. -EXPARG(1)) RETURN 5 IF (4.0*AH*AX .GT. -EPSLN(0)) GO TO 120 C IF (AX .GT. 3.0*AH) GO TO 10 IF (XPH .LT. 1.0) GO TO 110 GO TO 130 C------------------------------------------------- C FOR (AX LESS THAN OR EQUAL TO .40) C------------------------------------------------- 10 E = AMAX1(1.E-15,EPS) IF (AX .GT. 0.40) GO TO 30 H2 = XPH*XPH A2 = XMH*XMH X2 = AX + AX ST = 1. HF = XMH N = 0 N1 = 1 DN2 = 1. S = 0. 20 N = N + 1 N1 = N1 + 2 DN2 = -DN2/N ST = H2*ST + X2*HF HF = A2*HF T = ST*DN2/N1 S = S + T IF (ABS(T) .GT. E*ABS(S)) GO TO 20 S = 0.5 + (S + 0.5) AERF = 2.0*C*AH*S GO TO 45 C------------------------------------------------- C FOR (AX GREATER THAN .40) C------------------------------------------------- 30 N = 1 J = 0 H2 = 0. Z = EXP(-0.5*AX*AX) U = 2.0*AH*C*Z H3 = Z V = 2.0*H*H HF = 2.0*AX*AH S = 0. 35 H2 = (HF*H3 - V*H2)/N N = N + 1 H3 = (HF*H2 - V*H3)/N N = N + 1 HG = H3/N S = S + HG IF (ABS(HG) .GT. E*ABS(S)) GO TO 35 IF (J .NE. 0) GO TO 40 J = 1 GO TO 35 40 AERF = U*(S + Z) 45 IF (H .LT. 0.0) AERF = -AERF RETURN C------------------------------------------------- C SPECIAL CASES C------------------------------------------------- 100 IF (XPH .LT. 5.8) GO TO 110 IF (XMH .GT. -5.6) GO TO 120 AERF = SIGN(2.0,H) RETURN C 110 AERF = ERF(XPH) - ERF(XMH) IF (H .LT. 0.0) AERF = -AERF RETURN C 120 AERF = ERFC(XMH) IF (H .LT. 0.0) AERF = -AERF RETURN C 130 AERF = ERFC(XMH) - ERFC(XPH) IF (H .LT. 0.0) AERF = -AERF RETURN C 140 AERF = 2.0*C*H*(0.5 + (0.5 - (X*X + H*H/3.0))) RETURN C C THE VALUE IS 2.0*EXP(-X*X)*ERF(H) C 150 T = 2.0 X2 = X*X IF (X2 .GE. EPS) T = 2.0*EXP(-X2) IF (H*H .GE. 3.0*EPS) GO TO 160 AERF = C*H*T RETURN 160 AERF = T*ERF(H) RETURN END DOUBLE PRECISION FUNCTION DAERF (X, H) C----------------------------------------------------------------------- C COMPUTATION OF ERF(X + H) - ERF(X - H) C----------------------------------------------------------------------- DOUBLE PRECISION X, H DOUBLE PRECISION AH, AX, A2, C, DN2, E, EPS, HF, HG, H2, H3, * N, N1, P, S, ST, T, U, V, XMH, XPH, X2, Z DOUBLE PRECISION DERF, DERFC, DPMPAR, DEPSLN, DXPARG C--------------------- C C = 2/SQRT(PI) C P = LN(9*SQRT(PI)) C--------------------- DATA C /1.12837916709551257389615890312155D0/ DATA P /2.76959D0/ C--------------------- C C **** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE C SMALLEST NUMBER SUCH THAT 1.D0 + EPS .GT. 1.D0 . C EPS = DPMPAR(1) C C--------------------- DAERF = 0.D0 IF (H .EQ. 0.D0) RETURN C AH = DABS(H) AX = DABS(X) XPH = AX + AH XMH = AX - AH C T = DMAX1(AH,AX) T = T*T IF (1.6D0*T*T .LT. EPS) GO TO 140 IF ((AX*AH)**2 .LT. 0.5D0*EPS) GO TO 150 IF (AX .LE. AH) GO TO 100 C IF (XMH .LT. 9.D0) GO TO 5 IF (XMH*XMH + P .GT. -DXPARG(1)) RETURN 5 IF (4.D0*AH*AX .GT. -DEPSLN(0)) GO TO 120 C IF (AX .GT. 3.D0*AH) GO TO 10 IF (XPH .LT. 1.D0) GO TO 110 GO TO 130 C------------------------------------------------- C FOR (AX LESS THAN OR EQUAL TO .40) C------------------------------------------------- 10 E = DMAX1(1.D-30,EPS) IF (AX .GT. 0.4D0) GO TO 30 H2 = XPH*XPH A2 = XMH*XMH X2 = AX + AX ST = 1.D0 HF = XMH N = 0.D0 N1 = 1.D0 DN2 = 1.D0 S = 0.D0 20 N = N + 1.D0 N1 = N1 + 2.D0 DN2 = -DN2/N ST = H2*ST + X2*HF HF = A2*HF T = ST*DN2/N1 S = S + T IF (DABS(T) .GT. E*DABS(S)) GO TO 20 S = 0.5D0 + (0.5D0 + S) DAERF = 2.D0*C*AH*S GO TO 45 C------------------------------------------------- C FOR (AX GREATER THAN .40) C------------------------------------------------- 30 N = 1.D0 J = 0 H2 = 0.D0 Z = DEXP(-0.5D0*AX*AX) U = 2.D0*AH*C*Z H3 = Z V = 2.D0*H*H HF = 2.D0*AX*AH S = 0.D0 35 H2 = (HF*H3 - V*H2)/N N = N + 1.D0 H3 = (HF*H2 - V*H3)/N N = N + 1.D0 HG = H3/N S = S + HG IF (DABS(HG) .GT. E*DABS(S)) GO TO 35 IF (J .NE. 0) GO TO 40 J = 1 GO TO 35 40 DAERF = U*(S + Z) 45 IF (H .LT. 0.D0) DAERF = -DAERF RETURN C------------------------------------------------- C SPECIAL CASES C------------------------------------------------- 100 IF (XPH .LT. 8.5D0) GO TO 110 IF (XMH .GT. -8.3D0) GO TO 120 DAERF = DSIGN(2.D0,H) RETURN C 110 DAERF = DERF(XPH) - DERF(XMH) IF (H .LT. 0.D0) DAERF = -DAERF RETURN C 120 DAERF = DERFC(XMH) IF (H .LT. 0.D0) DAERF = -DAERF RETURN C 130 DAERF = DERFC(XMH) - DERFC(XPH) IF (H .LT. 0.D0) DAERF = -DAERF RETURN C 140 DAERF = 2.D0*C*H*(0.5D0 + (0.5D0 - (X*X + H*H/3.D0))) RETURN C C THE VALUE IS 2.0*EXP(-X*X)*ERF(H) C 150 T = 2.D0 X2 = X*X IF (X2 .GE. EPS) T = 2.D0*DEXP(-X2) IF (H*H .GE. 3.D0*EPS) GO TO 160 DAERF = C*H*T RETURN 160 DAERF = T*DERF(H) RETURN END FUNCTION PNDF(X,IND) C --------------- C A = 1/SQRT(2) C C = SQRT(2/PI) C --------------- DATA A/.707106781186548/ DATA C/.797884560802865/ C --------------- T = A*X IF (IND .NE. 0) GO TO 20 IF (X .LT. -8.0) GO TO 10 PNDF = 0.5*ERFC1(0,-T) RETURN 10 PNDF = C/ERFC1(1,-T) RETURN 20 IF (X .GT. 8.0) GO TO 30 PNDF = 0.5*ERFC1(0,T) RETURN 30 PNDF = C/ERFC1(1,T) RETURN END SUBROUTINE PNI (P, Q, D, W, IERR) C----------------------------------------------------------------------- C C EVALUATION OF THE INVERSE NORMAL DISTRIBUTION FUNCTION C C ------------ C C LET F(T) = 1/(SQRT(2*PI)*EXP(-T*T/2)). THEN THE FUNCTION C C PROB(X) = INTEGRAL FROM MINUS INFINITY TO X OF F(T) C C IS THE NORMAL DISTRIBUTION FUNCTION OF ZERO MEAN AND UNIT C VARIANCE. IT IS ASSUMED THAT P .GT. 0, Q .GT. 0, P + Q = 1, C AND D = P - 0.5. THE VALUE W IS COMPUTED WHERE PROB(W) = P. C C IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS. C C IERR = 0 NO INPUT ERRORS WERE DETECTED. W WAS COMPUTED. C IERR = 1 EITHER P OR Q IS INCORRECT. C IERR = 2 D IS INCORRECT. C C----------------------------------------------------------------------- C RT2 = SQRT(2) C------------------------ DATA RT2 /1.414213562373095/ C------------------------ T = AMIN1(P,Q) IF (T .LE. 0.0) GO TO 10 EPS = AMAX1(SPMPAR(1),1.E-15) W = 0.5 + (0.5 - (P + Q)) IF (ABS(W) .GT. 2.0*EPS) GO TO 10 C U = ABS(D + D) V = T + T W = ERFI(U, V) IF (W .LT. 0.0) GO TO 20 C IERR = 0 W = RT2*W IF (D .LT. 0.0) W = - W RETURN C C ERROR RETURN C 10 IERR = 1 RETURN 20 IERR = 2 RETURN END SUBROUTINE DPNI (P, Q, D, W, IERR) C----------------------------------------------------------------------- C C EVALUATION OF THE INVERSE NORMAL DISTRIBUTION FUNCTION C C ------------ C C LET F(T) = 1/(SQRT(2*PI)*EXP(-T*T/2)). THEN THE FUNCTION C C PROB(X) = INTEGRAL FROM MINUS INFINITY TO X OF F(T) C C IS THE NORMAL DISTRIBUTION FUNCTION OF ZERO MEAN AND UNIT C VARIANCE. IT IS ASSUMED THAT P .GT. 0, Q .GT. 0, P + Q = 1, C AND D = P - 0.5. THE VALUE W IS COMPUTED WHERE PROB(W) = P. C C IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS. C C IERR = 0 NO INPUT ERRORS WERE DETECTED. W WAS COMPUTED. C IERR = 1 EITHER P OR Q IS INCORRECT. C IERR = 2 D IS INCORRECT. C C----------------------------------------------------------------------- DOUBLE PRECISION P, Q, D, W DOUBLE PRECISION EPS, RT2, U, V, T DOUBLE PRECISION DPMPAR, DERFI C------------------------ C RT2 = SQRT(2) C------------------------ DATA RT2 /1.4142135623730950488016887242097D0/ C------------------------ T = DMIN1(P,Q) IF (T .LE. 0.D0) GO TO 10 EPS = DPMPAR(1) W = 0.5D0 + (0.5D0 - (P + Q)) IF (DABS(W) .GT. 2.D0*EPS) GO TO 10 C U = DABS(D + D) V = T + T W = DERFI(U, V) IF (W .LT. 0.D0) GO TO 20 C IERR = 0 W = RT2*W IF (D .LT. 0.D0) W = - W RETURN C C ERROR RETURN C 10 IERR = 1 RETURN 20 IERR = 2 RETURN END REAL FUNCTION DAW(X) C----------------------------------------------------------------------- C C THIS FUNCTION COMPUTES SINGLE PRECISION VALUES OF DAWSONS C INTEGRAL, C C EXP(-X*X) * INTEGRAL (FROM 0 TO X) EXP(T*T) DT, C C DEFINED FOR ALL REAL ARGUMENTS. C C THE MAIN COMPUTATION INVOLVES EVALUATION OF RATIONAL CHEBYSHEV C APPROXIMATIONS PUBLISHED IN MATH. COMP. 24, 171-178(1970) BY C CODY, PACIOREK AND THACHER. C C----------------------------------------------------------------------- REAL P1(9),Q1(9),P2(8),Q2(7),P3(8),Q3(7),P4(7),Q4(6), * FRAC,SUMP,SUMQ,W2,X,Y,XLARGE,XSMALL C--------------- DATA XLARGE/16777216.0/, XSMALL/.59604644775391E-07/ C--------------- C C COEFFICIENTS FOR R(8,8) APPROXIMATION, C USED FOR ABS(X) .LT. 2.5 C C--------------- DATA P1(1)/.100000000000000E+01/, P1(2)/-.135599049815353E+00/, * P1(3)/.456738974064825E-01/, P1(4)/-.258323495918050E-02/, * P1(5)/.360079463580992E-03/, P1(6)/-.944375029163387E-05/, * P1(7)/.634674256878843E-06/, P1(8)/-.711645839183817E-08/, * P1(9)/.977985913592343E-10/ DATA Q1(1)/.100000000000000E+01/, Q1(2)/.531067616851310E+00/, * Q1(3)/.133052308640737E+00/, Q1(4)/.206907491644210E-01/, * Q1(5)/.220437428972266E-02/, Q1(6)/.166706801664365E-03/, * Q1(7)/.887964712053131E-05/, Q1(8)/.311750854173480E-06/, * Q1(9)/.574807177698046E-08/ C--------------- C C COEFFICIENTS FOR R(7,7) APPROXIMATION, C IN J-FRACTION FORM, USED FOR C 2.5 .LE. ABS(X) .LT. 3.5 C C--------------- DATA P2(1)/-.150695651187161E+01/, P2(2)/ .293365747395449E+02/, * P2(3)/-.400000893643550E+02/, P2(4)/-.757931918089369E-01/, * P2(5)/-.889106479747812E+01/, P2(6)/ .152644099623699E+02/, * P2(7)/-.597678086823489E+01/, P2(8)/ .500236896088668E+00/ DATA Q2(1)/-.673106069744813E+00/, Q2(2)/ .124486788262252E+04/, * Q2(3)/ .721193217600229E+01/, Q2(4)/ .112461662024575E+03/, * Q2(5)/ .729177556415532E+02/, Q2(6)/ .115840292551888E+03/, * Q2(7)/ .226064666074309E+00/ C--------------- C C COEFFICIENTS FOR R(7,7) APPROXIMATION, C IN J-FRACTION FORM, USED FOR C 3.5 .LE. ABS(X) .LE. 5.0 C C--------------- DATA P3(1)/ .476405645273229E+01/, P3(2)/-.266167674896399E+02/, * P3(3)/-.916804879813552E+01/, P3(4)/-.150507703496692E+02/, * P3(5)/ .506460153742231E+01/, P3(6)/-.498544802986608E+01/, * P3(7)/-.149838042036691E+01/, P3(8)/ .499999902705054E+00/ DATA Q3(1)/ .287776122973187E+03/, Q3(2)/ .256105722342226E+02/, * Q3(3)/ .751701277744067E+02/, Q3(4)/ .146515167783109E+03/, * Q3(5)/ .330707724676114E+02/, Q3(6)/-.148715811787195E+01/, * Q3(7)/ .250011459611839E+00/ C--------------- C C COEFFICIENTS FOR R(6,6) APPROXIMATION, C IN J-FRACTION FORM, USED FOR ABS(X) .GT. 5.0 C C--------------- DATA P4(1)/-.315576735766984E+02/, P4(2)/-.100791496592972E+02/, * P4(3)/-.710713709224200E+01/, P4(4)/-.596879853243925E+01/, * P4(5)/-.449773645376092E+01/, P4(6)/-.249999965398199E+01/, * P4(7)/ .499999999999330E+00/ DATA Q4(1)/ .168874162155616E+03/, Q4(2)/ .698280748271071E+01/, * Q4(3)/-.213029621139181E+02/, Q4(4)/-.712157348463305E+01/, * Q4(5)/-.250005973192356E+01/, Q4(6)/ .750000000715687E+00/ C----------------------------------------------------------------------- C IF (ABS(X) .GT. XLARGE) GO TO 500 IF (ABS(X) .LT. XSMALL) GO TO 600 Y = X * X IF (Y .GE. 6.25E0) GO TO 200 C C ---------- ABS(X) .LT. 2.5 ---------- C SUMP = (((((((P1(9) * Y + P1(8)) * Y + P1(7)) * Y + P1(6)) 1 * Y + P1(5)) * Y + P1(4)) * Y + P1(3)) * Y + P1(2)) 2 * Y + P1(1) SUMQ = (((((((Q1(9) * Y + Q1(8)) * Y + Q1(7)) * Y + Q1(6)) 1 * Y + Q1(5)) * Y + Q1(4)) * Y + Q1(3)) * Y + Q1(2)) 2 * Y + Q1(1) DAW = X * SUMP / SUMQ GO TO 1000 C C ---------- 2.5 .LE. ABS(X) .LT. 3.5 ---------- C 200 IF (Y .GE. 12.25E0) GO TO 300 FRAC = 0.0E0 C DO 220 I = 1, 7 220 FRAC = Q2(I) / (P2(I) + Y + FRAC) C DAW = (P2(8) + FRAC) / X GO TO 1000 C C ---------- 3.5 .LE. ABS(X) .LT. 5.0 ---------- C 300 IF (Y .GE. 25.0E0) GO TO 400 FRAC = 0.0E0 C DO 320 I = 1, 7 320 FRAC = Q3(I) / (P3(I) + Y + FRAC) C DAW = (P3(8) + FRAC) / X GO TO 1000 C C ---------- 5.0 .LE. ABS(X) .LE. XLARGE ---------- C 400 W2 = 1.0E0 / X / X FRAC = 0.0E0 C DO 420 I = 1, 6 420 FRAC = Q4(I) / (P4(I) + Y + FRAC) C FRAC = P4(7) + FRAC DAW = (0.5E0 + 0.5E0 * W2 * FRAC) / X GO TO 1000 C C ---------- XLARGE .LT. ABS(X) ---------- C 500 DAW = 0.5E0 / X GO TO 1000 C C ---------- RETURN FOR SMALL X ---------- C 600 DAW = X C 1000 RETURN END DOUBLE PRECISION FUNCTION DPDAW (X) C----------------------------------------------------------------------- C DOUBLE PRECISION COMPUTATION OF DAWSONS INTEGRAL C----------------------------------------------------------------------- DOUBLE PRECISION X, A(20), B(45), AX, EPS, T, W DOUBLE PRECISION DCSEVL, DPDAW0 C---------------------------- DATA EPS /1.D-31/ C---------------------------- DATA A(1) /-.6666666666666666666666666666657D+00/, * A(2) / .2666666666666666666666666665302D+00/, * A(3) /-.7619047619047619047619046823290D-01/, * A(4) / .1693121693121693121693097101950D-01/, * A(5) /-.3078403078403078403073750370528D-02/, * A(6) / .4736004736004736004148385001356D-03/, * A(7) /-.6314672981339647953899064401849D-04/, * A(8) / .7429027036870170692270376716931D-05/, * A(9) /-.7820028459863171536925638117632D-06/, * A(10) / .7447646152244351276445219666744D-07/ DATA A(11) /-.6476214045244314289022051868963D-08/, * A(12) / .5180971231894821888421654461823D-09/, * A(13) /-.3837756389504541092817011259727D-10/, * A(14) / .2646727414301012080897585412600D-11/, * A(15) /-.1707553348198261876085879075486D-12/, * A(16) / .1034770025122653524451023758330D-13/, * A(17) /-.5905667147861158816695814259561D-15/, * A(18) / .3157018166820009192834256496230D-16/, * A(19) /-.1501742103181747984387915732309D-17/, * A(20) / .4921379778280206677674574916266D-19/ C---------------------------- DATA B(1) /-.56886544105215527114160533733674D-01/, * B(2) /-.31811346996168131279322878048822D+00/, * B(3) / .20873845413642236789741580198858D+00/, * B(4) /-.12475409913779131214073498314784D+00/, * B(5) / .67869305186676777092847516423676D-01/, * B(6) /-.33659144895270939503068230966587D-01/, * B(7) / .15260781271987971743682460381640D-01/, * B(8) /-.63483709625962148230586094788535D-02/, * B(9) / .24326740920748520596865966109343D-02/, * B(10) /-.86219541491065032038526983549637D-03/ DATA B(11) / .28376573336321625302857636538295D-03/, * B(12) /-.87057549874170423699396581464335D-04/, * B(13) / .24986849985481658331800044137276D-04/, * B(14) /-.67319286764160294344603050339520D-05/, * B(15) / .17078578785573543710504524047844D-05/, * B(16) /-.40917551226475381271896592490038D-06/, * B(17) / .92828292216755773260751785312273D-07/, * B(18) /-.19991403610147617829845096332198D-07/, * B(19) / .40963490644082195241210487868917D-08/, * B(20) /-.80032409540993168075706781753561D-09/ DATA B(21) / .14938503128761465059143225550110D-09/, * B(22) /-.26687999885622329284924651063339D-10/, * B(23) / .45712216985159458151405617724103D-11/, * B(24) /-.75187305222043565872243727326771D-12/, * B(25) / .11893100052629681879029828987302D-12/, * B(26) /-.18116907933852346973490318263084D-13/, * B(27) / .26611733684358969193001612199626D-14/, * B(28) /-.37738863052129419795444109905930D-15/, * B(29) / .51727953789087172679680082229329D-16/, * B(30) /-.68603684084077500979419564670102D-17/ DATA B(31) / .88123751354161071806469337321745D-18/, * B(32) /-.10974248249996606292106299624652D-18/, * B(33) / .13261199326367178513595545891635D-19/, * B(34) /-.15562732768137380785488776571562D-20/, * B(35) / .17751425583655720607833415570773D-21/, * B(36) /-.19695006967006578384953608765439D-22/, * B(37) / .21270074896998699661924010120533D-23/, * B(38) /-.22375398124627973794182113962666D-24/, * B(39) / .22942768578582348946971383125333D-25/, * B(40) /-.22943788846552928693329592319999D-26/ DATA B(41) / .22391702100592453618342297600000D-27/, * B(42) /-.21338230616608897703678225066666D-28/, * B(43) / .19866196585123531518028458666666D-29/, * B(44) /-.18079295866694391771955199999999D-30/, * B(45) / .16090686015283030305450666666666D-31/ C---------------------------- AX = DABS(X) IF (AX .GE. 4.D0) GO TO 30 T = X*X IF (AX .GT. 1.D0) GO TO 20 C C ABS(X) .LE. 1 C DPDAW = X IF (T .LT. EPS) RETURN C W = A(20) DO 10 I = 1,19 K = 20 - I W = T*W + A(K) 10 CONTINUE DPDAW = X * (0.75D0 + (0.25D0 + T*W)) RETURN C C 1 .LT. ABS(X) .LT. 4 C 20 DPDAW = X * (.25D0 + DCSEVL(.125D0*T - 1.D0, B, 45)) RETURN C C ABS(X) .GE. 4 C 30 DPDAW = DPDAW0(AX)/X RETURN END DOUBLE PRECISION FUNCTION DPDAW0 (X) C----------------------------------------------------------------------- C C EVALUATION OF X*DAW(X) FOR X .GE. 4 C WHERE DAW(X) IS THE DAWSON INTEGRAL C C----------------------------------------------------------------------- DOUBLE PRECISION X, T, U, V, W DOUBLE PRECISION A0, A1, A2, A3, A4, A5, A6, A7, A8, A9, A10, * A11, A12, A13, A14, A15, A16, A17, A18, * B1, B2, B3, B4 DOUBLE PRECISION C0, C1, C2, C3, C4, C5, C6, C7, C8, C9, C10, * C11, C12, C13, C14, * D1, D2, D3, D4, D5, D6, D7, D8 DOUBLE PRECISION E0, E1, E2, E3, E4, E5, E6, E7, E8, E9, E10, * F1, F2, F3, F4, F5, F6, F7, F8, F9, F10 DOUBLE PRECISION G0, G1, G2, G3, G4, G5, G6, G7, G8, G9, G10, * G11, H1, H2, H3, H4, H5, H6, H7, H8, H9, H10 DOUBLE PRECISION S0, S1, S2, S3, S4, S5 DOUBLE PRECISION P0, P1, P2, P3, P4, P5, Q1, Q2, Q3, Q4, Q5 C---------------------------- DATA A0 / .59682223611279114961181337D-06/, * A1 / .17685355947137064277328544D-05/, * A2 / .46539151619719879425847199D-05/, * A3 / .60206549750426063518629015D-05/, * A4 / .71968323029042065431569341D-05/, * A5 / .30632314265730271259576310D-05/, * A6 / .58023977792358623878717970D-06/, * A7 /-.79009104459686847104040749D-06/, * A8 /-.48136647436848802449955585D-06/, * A9 / .15516701696125663593787151D-05/ DATA A10 / .41907470564012404920368069D-05/, * A11 / .58027971313506864533128271D-05/, * A12 / .55370618938769991926278955D-05/, * A13 / .38921890500515083447099834D-05/, * A14 / .20373391058442140223632125D-05/, * A15 / .77894504402267231707108862D-06/, * A16 / .20671717275442647450228015D-06/, * A17 / .34163346266402336952767687D-07/, * A18 / .26550833614486808486653527D-08/ C---------------------------- DATA B1 / .24655153970246619491575782D+01/, * B2 / .62943144539382480033771054D+01/, * B3 / .62122304537339562619049238D+01/, * B4 / .72256247680648550388609993D+01/ C---------------------------- DATA C0 / .59682220964671964619429990D-06/, * C1 / .15714896176335781761895194D-05/, * C2 / .38969553030269966874001463D-05/, * C3 / .52383725295173020317044495D-05/, * C4 / .68105053752194312932660379D-05/, * C5 / .54424292166005622934118953D-05/, * C6 / .42426204827598626398351706D-05/, * C7 / .16034175582037599078896885D-05/, * C8 / .40869743822567069272296881D-06/, * C9 /-.28877279517645392833652391D-06/ DATA C10 /-.23330912423546272053845073D-06/, * C11 /-.52391219684126122047201575D-07/, * C12 / .21002079856304960793765863D-07/, * C13 / .15999459808634652894884878D-07/, * C14 / .30942877932880022278704223D-08/ C---------------------------- DATA D1 / .21353586303464124681525146D+01/, * D2 / .51903635881846225790635588D+01/, * D3 / .55426108503039000945912263D+01/, * D4 / .72404445472735688881512590D+01/, * D5 / .42043425514299588216548098D+01/, * D6 / .39555198251457455938284071D+01/, * D7 / .96558431899415447517392039D+00/, * D8 / .85802563214754700974536646D+00/ C---------------------------- DATA E0 / .59682220964671964619429989D-06/, * E1 / .84093250039847132132545694D-06/, * E2 / .21215362314612857942015465D-05/, * E3 / .17544801458346344458699925D-05/, * E4 / .23300467572238537581015267D-05/, * E5 / .10789302963153438789721000D-05/, * E6 / .84593690165753140097573765D-06/, * E7 / .58921927492401852305814815D-07/, * E8 / .88699252882391671775568852D-08/, * E9 /-.45367333700483839577191791D-07/ DATA E10 /-.57476692572774473717756092D-08/ C---------------------------- DATA F1 / .91128032791938035312580060D+00/, * F2 / .28248447610354665352098820D+01/, * F3 / .12208226691968579661669930D+01/, * F4 / .26127044898109340807106578D+01/, * F5 / .34850941500747816686718301D+00/, * F6 / .11058424028893031129155960D+01/, * F7 /-.58583432304677947215235382D-01/, * F8 / .22235753204903993496120223D+00/, * F9 /-.22116625272550591073419658D-01/, * F10 / .14938281115881437851795141D-01/ C---------------------------- DATA G0 / .59682220962853689178993039D-06/, * G1 / .10399202637216492921747166D-05/, * G2 / .20011159669496258291170369D-05/, * G3 / .19689301951834731308289277D-05/, * G4 / .18861506874082130108404839D-05/, * G5 / .10403672611266773427898830D-05/, * G6 / .42700287233074049241986613D-06/, * G7 /-.16199303908856237550380048D-07/, * G8 /-.73900110466591484816182863D-07/, * G9 /-.21369058482679700785965255D-07/ DATA G10 / .42853587024761116737793072D-08/, * G11 /-.27226352610679391576406666D-09/ C---------------------------- DATA H1 / .12446924554654251972427023D+01/, * H2 / .24571243397858142676189669D+01/, * H3 / .16710488988253927773151334D+01/, * H4 / .17260859791081983044753913D+01/, * H5 / .67406536368694046314885196D+00/, * H6 / .47403526893401885333000527D+00/, * H7 / .96251479080923959509108658D-01/, * H8 / .53334517885765587426678624D-01/, * H9 / .39450307003297031975491216D-02/, * H10 / .20209221166462656808887976D-02/ C---------------------------- DATA S0 / .8210986449041747719684610504710D-02/, * S1 / .8646073144815053170065230898334D-02/, * S2 / .4768322737615973285410030924398D-03/, * S3 / .4792593707378225992657970685396D-04/, * S4 / .7507677744363576693833551190204D-05/, * S5 / .1737929446861228512373840727547D-05/ C---------------------------- DATA P0 / .29531250000000000000002D+02/, * P1 /-.14571781607273299440392D+04/, * P2 / .24285318385898860175073D+05/, * P3 /-.15843555052114168113822D+06/, * P4 / .32969397422638395586636D+06/, * P5 /-.55331506994311967089636D+04/ DATA Q1 /-.54843599093412230906873D+02/, * Q2 / .10882497826844164906477D+04/, * Q3 /-.96578534881552358457185D+04/, * Q4 / .37803382357862589384458D+05/, * Q5 /-.51283783372259864777146D+05/ C---------------------------- IF (X .GE. 12.D0) GO TO 50 T = (32.D0/(X*X) - 0.5D0) - 0.5D0 IF (T .GE. 0.D0) GO TO 20 C C -7/9 .LE. T .LE. -0.4 C IF (T .GT. -0.4D0) GO TO 10 U = ((((((((A18*T + A17)*T + A16)*T + A15)*T + A14)*T + * A13)*T + A12)*T + A11)*T + A10)*T + A9 U = ((((((((U*T + A8)*T + A7)*T + A6)*T + A5)*T + * A4)*T + A3)*T + A2)*T + A1)*T + A0 V = (((B4*T + B3)*T + B2)*T + B1)*T + 1.D0 GO TO 40 C C -0.4 .LT. T .LT. 0 C 10 U = ((((((((C14*T + C13)*T + C12)*T + C11)*T + C10)*T + * C9)*T + C8)*T + C7)*T + C6)*T + C5 U = ((((U*T + C4)*T + C3)*T + C2)*T + C1)*T + C0 V = (((((((D8*T + D7)*T + D6)*T + D5)*T + D4)*T + * D3)*T + D2)*T + D1)*T + 1.D0 GO TO 40 C C 0 .LE. T .LE. 0.4 C 20 IF (T .GT. 0.4D0) GO TO 30 U = (((((((((E10*T + E9)*T + E8)*T + E7)*T + E6)*T + * E5)*T + E4)*T + E3)*T + E2)*T + E1)*T + E0 V = (((((((((F10*T + F9)*T + F8)*T + F7)*T + F6)*T + * F5)*T + F4)*T + F3)*T + F2)*T + F1)*T + 1.D0 GO TO 40 C C 0.4 .LT. T .LE. 1 C 30 U = ((((((((G11*T + G10)*T + G9)*T + G8)*T + G7)*T + * G6)*T + G5)*T + G4)*T + G3)*T + G2 U = (U*T + G1)*T + G0 V = (((((((((H10*T + H9)*T + H8)*T + H7)*T + H6)*T + * H5)*T + H4)*T + H3)*T + H2)*T + H1)*T + 1.D0 C C THE ABOVE FOUR MINIMAX APPROXIMATIONS U/V C ARE ACCURATE TO WITHIN 1 UNIT OF THE 25-TH C SIGNIFICANT DIGIT. THUS, THE APPROXIMATION C FOR W IS ACCURATE TO WITHIN 1 UNIT OF THE C 29-TH SIGNIFICANT DIGIT. C 40 W = ((((((U/V)*T + S5)*T + S4)*T + S3)*T + S2)*T + * S1)*T + S0 DPDAW0 = 0.5D0 + W RETURN C C X .GE. 12 C 50 T = (1.D0/X)**2 W = (((((P5*T + P4)*T + P3)*T + P2)*T + P1)*T + P0)/ * (((((Q5*T + Q4)*T + Q3)*T + Q2)*T + Q1)*T + 1.D0) W = ((((W*T + 6.5625D0)*T + 1.875D0)*T + 0.75D0)*T + * 0.5D0)*T + 1.D0 DPDAW0 = 0.5D0*W RETURN END SUBROUTINE CFRNLI (MO, Z, W) C----------------------------------------------------------------------- C C COMPUTATION OF THE COMPLEX FRESNEL INTEGRAL E(Z) C C ---------------- C C W = E(Z) IF MO = 0 C W = EXP(-Z)*E(Z) OTHERWISE C C----------------------------------------------------------------------- COMPLEX Z, W REAL CD(18), CE(18), QF(2), SM(2), TM(2), TS(2), ZR(2) C------------------------ C C = 1/SQRT(PI) C C0 = -1/SQRT(2) C------------------------ DATA C / .564189583547756/ DATA C0 /-.707106781186548/ C------------------------ DATA CD(1) /0.00000000000000E00/, CD(2) /2.08605856013476E-2/, 1 CD(3) /8.29806940495687E-2/, CD(4) /1.85421653326079E-1/, 2 CD(5) /3.27963479382361E-1/, CD(6) /5.12675279912828E-1/, 3 CD(7) /7.45412958045105E-1/, CD(8) /1.03695067418297E00/, 4 CD(9) /1.40378061255437E00/, CD(10)/1.86891662214001E00/, 5 CD(11)/2.46314830523929E00/, CD(12)/3.22719383737352E00/, 6 CD(13)/4.21534348280013E00/, CD(14)/5.50178873151549E00/, 7 CD(15)/7.19258966683102E00/, CD(16)/9.45170208076408E00/, 8 CD(17)/1.25710718314784E+1/, CD(18)/1.72483537216334E+1/ DATA CE(1) /8.15723083324096E-2/, CE(2) /1.59285285253437E-1/, 1 CE(3) /1.48581625614499E-1/, CE(4) /1.33219670836245E-1/, 2 CE(5) /1.15690392878957E-1/, CE(6) /9.78580959447535E-2/, 3 CE(7) /8.05908834297624E-2/, CE(8) /6.40204538609872E-2/, 4 CE(9) /4.81445242767885E-2/, CE(10)/3.33540658473295E-2/, 5 CE(11)/2.05548099470193E-2/, CE(12)/1.07847403887506E-2/, 6 CE(13)/4.55634892214219E-3/, CE(14)/1.43984458138925E-3/, 7 CE(15)/3.07056139834171E-4/, CE(16)/3.78156541168541E-5/, 8 CE(17)/2.05173509616121E-6/, CE(18)/2.63564823682747E-8/ C------------------------ X = REAL(Z) Y = AIMAG(Z) R = CPABS(X, Y) IF (R .EQ. 0.0) GO TO 200 C C EVALUATION OF ZR = SQRT(2*Z/PI) C IF (X .GE. 0.0) GO TO 10 ZR(2) = SQRT(R - X) ZR(1) = Y/ZR(2) GO TO 11 10 ZR(1) = SQRT(R + X) IF (Y .LT. 0.0) ZR(1) = -ZR(1) ZR(2) = Y/ZR(1) 11 ZR(1) = C*ZR(1) ZR(2) = C*ZR(2) C IF (R .LE. 1.0) GO TO 20 IF (R .GE. 38.0) GO TO 60 IF (X .LT. 0.016*Y*Y) GO TO 50 C C TAYLOR SERIES C 20 SM(1) = 0.0 SM(2) = 0.0 TM(1) = ZR(1) TM(2) = ZR(2) PM = 0.0 30 PM = PM + 1.0 DM = 2.0*PM + 1.0 TS(1) = TM(1)*X - TM(2)*Y TS(2) = TM(1)*Y + TM(2)*X TM(1) = TS(1)/PM TM(2) = TS(2)/PM TS(1) = TM(1)/DM TS(2) = TM(2)/DM IF (ABS(SM(1)) + ABS(TS(1)) .NE. ABS(SM(1))) GO TO 31 IF (ABS(SM(2)) + ABS(TS(2)) .EQ. ABS(SM(2))) GO TO 40 31 SM(1) = SM(1) + TS(1) SM(2) = SM(2) + TS(2) GO TO 30 40 SM(1) = ZR(1) + SM(1) SM(2) = (C0 + ZR(2)) + SM(2) C IF (MO .EQ. 0) GO TO 120 QM = EXP(-X) QF(1) = QM*COS(-Y) QF(2) = QM*SIN(-Y) GO TO 110 C C RATIONAL FUNCTION APPROXIMATION C 50 SM(1) = 0.0 SM(2) = 0.0 DO 51 I = 1,18 TS(1) = X - CD(I) TS(2) = Y SS = TS(1)*TS(1) + TS(2)*TS(2) TM(1) = CE(I)*TS(1)/SS TM(2) = -CE(I)*TS(2)/SS SM(1) = SM(1) + TM(1) SM(2) = SM(2) + TM(2) 51 CONTINUE TS(1) = ZR(1)*SM(1) - ZR(2)*SM(2) TS(2) = ZR(1)*SM(2) + ZR(2)*SM(1) SM(1) = 0.5*TS(1) SM(2) = 0.5*TS(2) GO TO 100 C C ASYMPTOTIC EXPANSION C 60 QF(1) = (X/R)/R QF(2) = -(Y/R)/R TM(1) = QF(1) TM(2) = QF(2) SM(1) = TM(1) SM(2) = TM(2) PM = -0.5 70 PM = PM + 1.0 TS(1) = TM(1)*QF(1) - TM(2)*QF(2) TS(2) = TM(1)*QF(2) + TM(2)*QF(1) TM(1) = PM*TS(1) TM(2) = PM*TS(2) IF (ABS(SM(1)) + ABS(TM(1)) .NE. ABS(SM(1))) GO TO 71 IF (ABS(SM(2)) + ABS(TM(2)) .EQ. ABS(SM(2))) GO TO 80 71 SM(1) = SM(1) + TM(1) SM(2) = SM(2) + TM(2) IF (PM .LT. 25.5) GO TO 70 80 TS(1) = ZR(1)*SM(1) - ZR(2)*SM(2) TS(2) = ZR(1)*SM(2) + ZR(2)*SM(1) SM(1) = 0.5*TS(1) SM(2) = 0.5*TS(2) IF (ZR(2) .LT. 8.E-3) GO TO 210 C C TERMINATION C 100 IF (MO .NE. 0) GO TO 120 QM = EXP(X) QF(1) = QM*COS(Y) QF(2) = QM*SIN(Y) C 110 TS(1) = QF(1)*SM(1) - QF(2)*SM(2) TS(2) = QF(1)*SM(2) + QF(2)*SM(1) SM(1) = TS(1) SM(2) = TS(2) C 120 W = CMPLX(SM(1),SM(2)) RETURN C C CASE WHEN Z = 0 C 200 W = CMPLX(0.0,C0) RETURN C C MODIFIED ASYMPTOTIC EXPANSION C 210 IF (MO .NE. 0) GO TO 220 QM = EXP(X) QF(1) = QM*COS(Y) QF(2) = QM*SIN(Y) TS(1) = QF(1)*SM(1) - QF(2)*SM(2) TS(2) = QF(1)*SM(2) + QF(2)*SM(1) W = CMPLX(TS(1), C0 + TS(2)) RETURN C 220 IF (-X .LE. EXPARG(1)) GO TO 120 QM = C0*EXP(-X) SM(1) = SM(1) + QM*SIN(Y) SM(2) = SM(2) + QM*COS(Y) W = CMPLX(SM(1),SM(2)) RETURN END SUBROUTINE FRNL (T, C, S) C----------------------------------------------------------------------- C EVALUATION OF THE REAL FRESNEL INTEGRALS C----------------------------------------------------------------------- REAL N REAL A(6),B(6),CP(13),SP(13) REAL PN(6),PD(6),QN(6),QD(6) REAL AN(6),AD(6),BN(6),BD(6) REAL CN(5),CD(5),DN(5),DD(5) REAL FP(7),GP(7),P(6),Q(6) C-------------------------- DATA PI/3.1415926535898/ C-------------------------- DATA A(1)/-.119278241233760E-05/, A(2)/.540730666359417E-04/, 1 A(3)/-.160488306381990E-02/, A(4)/.281855008757077E-01/, 2 A(5)/-.246740110027210E+00/, A(6)/.100000000000000E+01/ DATA B(1)/-.155653074871090E-06/, B(2)/.844415353045065E-05/, 1 B(3)/-.312116934326082E-03/, B(4)/.724478420395276E-02/, 2 B(5)/-.922805853580325E-01/, B(6)/.523598775598300E+00/ C-------------------------- DATA CP(1) /.114739945188034E-20/, CP(2) /-.384444827287950E-18/, 1 CP(3) /.832125729394275E-16/, CP(4) /-.142979507360076E-13/, 2 CP(5) /.198954961821465E-11/, CP(6) /-.220226545457144E-09/, 3 CP(7) /.188434924092257E-07/, CP(8) /-.120009722914157E-05/, 4 CP(9) /.540741337442140E-04/, CP(10)/-.160488313553028E-02/, 5 CP(11)/.281855008777956E-01/, CP(12)/-.246740110027196E+00/, 6 CP(13)/.999999999999996E+00/ DATA SP(1) /.705700784853927E-22/, SP(2) /-.252757991492418E-19/, 1 SP(3) /.594117488940008E-17/, SP(4) /-.112161631555448E-14/, 2 SP(5) /.173332189994074E-12/, SP(6) /-.215742302078015E-10/, 3 SP(7) /.210821173208116E-08/, SP(8) /-.156471443116560E-06/, 4 SP(9) /.844427287845253E-05/, SP(10)/-.312116942346186E-03/, 5 SP(11)/.724478420418951E-02/, SP(12)/-.922805853580323E-01/, 6 SP(13)/.523598775598300E+00/ C-------------------------- DATA PN(1)/.318309816100920E+00/, PN(2)/.134919391391516E+02/, 1 PN(3)/.158258097490377E+03/, PN(4)/.598796451682535E+03/, 2 PN(5)/.632369782194966E+03/, PN(6)/.967985390141920E+02/ DATA PD(1)/.100000000000000E+01/, PD(2)/.426900960480796E+02/, 1 PD(3)/.509085485682426E+03/, PD(4)/.200034664144742E+04/, 2 PD(5)/.231910140792937E+04/, PD(6)/.486678558201084E+03/ DATA QN(1)/.101320876178478E+00/, QN(2)/.490534697099052E+01/, 1 QN(3)/.652095157811808E+02/, QN(4)/.274183825747887E+03/, 2 QN(5)/.305040725009211E+03/, QN(6)/.364566615872326E+02/ DATA QD(1)/.100000000000000E+01/, QD(2)/.499330024470621E+02/, 1 QD(3)/.709854097670206E+03/, QD(4)/.343470762861172E+04/, 2 QD(5)/.522213879312684E+04/, QD(6)/.168801831831851E+04/ C-------------------------- DATA AN(1)/.318309885869756E+00/, AN(2)/.254179177393500E+02/, 1 AN(3)/.575003792540838E+03/, AN(4)/.426673405867140E+04/, 2 AN(5)/.891831887923938E+04/, AN(6)/.267955736537967E+04/ DATA AD(1)/.100000000000000E+01/, AD(2)/.801567066285184E+02/, 1 AD(3)/.182971463354850E+04/, AD(4)/.138848884373420E+05/, 2 AD(5)/.309228411873207E+05/, AD(6)/.120421274105856E+05/ DATA BN(1)/.101321181932417E+00/, BN(2)/.925021984290547E+01/, 1 BN(3)/.240932023056602E+03/, BN(4)/.206079616836437E+04/, 2 BN(5)/.484901973010149E+04/, BN(6)/.130680669688315E+04/ DATA BD(1)/.100000000000000E+01/, BD(2)/.928158182389149E+02/, 1 BD(3)/.250926840439955E+04/, BD(4)/.233924458152954E+05/, 2 BD(5)/.685638896406835E+05/, BD(6)/.418593101455019E+05/ C-------------------------- DATA CN(1)/.318309886182000E+00/, CN(2)/.299191968327887E+02/, 1 CN(3)/.691428839605668E+03/, CN(4)/.394539800974744E+04/, 2 CN(5)/.290314254767015E+04/ DATA CD(1)/.100000000000000E+01/, CD(2)/.942978925136851E+02/, 1 CD(3)/.219977296283666E+04/, CD(4)/.129726479671006E+05/, 2 CD(5)/.114991427758165E+05/ DATA DN(1)/.101321183630876E+00/, DN(2)/.110988033615242E+02/, 1 DN(3)/.306282306497228E+03/, DN(4)/.213130259794164E+04/, 2 DN(5)/.171270676541694E+04/ DATA DD(1)/.100000000000000E+01/, DD(2)/.111060616085627E+03/, 1 DD(3)/.318197586347414E+04/, DD(4)/.249342095714049E+05/, 2 DD(5)/.359241903823488E+05/ C-------------------------- DATA FP(1)/.449763389301234E+05/, FP(2)/-.188763642051836E+04/, 1 FP(3)/.669261097103246E+02/, FP(4)/-.343966606879114E+01/, 2 FP(5)/.343112896133346E+00/, FP(6)/-.967546019461500E-01/, 3 FP(7)/.318309886183465E+00/ DATA GP(1)/.316642183365360E+06/, GP(2)/-.120618995106638E+05/, 1 GP(3)/.359164749179351E+03/, GP(4)/-.142252603258172E+02/, 2 GP(5)/.982934118445454E+00/, GP(6)/-.153989722912325E+00/, 3 GP(7)/.101321183639714E+00/ C-------------------------- DATA P(1)/-654729075.0/, P(2)/2027025.0/, P(3)/-10395.0/, 1 P(4)/105.0/, P(5)/-3.0/, P(6)/1.0/ DATA Q(1)/-13749310575.0/, Q(2)/34459425.0/, Q(3)/-135135.0/, 1 Q(4)/945.0/, Q(5)/-15.0/, Q(6)/1.0/ C-------------------------- C C ****** MAX IS A MACHINE DEPENDENT CONSTANT. MAX IS THE C LARGEST POSITIVE INTEGER THAT MAY BE USED. C MAX = IPMPAR(3) C C----------------------------------------------------------------------- X = ABS(T) IF (X .GT. 4.0) GO TO 50 XX = X*X Y = XX*XX C----------------------------------------------------------------------- C EVALUATION OF C(X) AND S(X) FOR X .LT. 1.65 C WHERE X = ABS(T) C----------------------------------------------------------------------- IF (X .GT. 0.6) GO TO 10 C = ((((A(1)*Y + A(2))*Y + A(3))*Y + A(4))*Y + A(5))*Y + A(6) S = ((((B(1)*Y + B(2))*Y + B(3))*Y + B(4))*Y + B(5))*Y + B(6) C = T*C S = T*XX*S RETURN C 10 IF (X .GE. 1.65) GO TO 20 C = CP(1) S = SP(1) DO 11 I = 2,13 C = CP(I) + C*Y 11 S = SP(I) + S*Y C = T*C S = T*XX*S RETURN C----------------------------------------------------------------------- C EVALUATION OF THE AUXILIARY FUNCTIONS F(X) AND G(X) C FOR X .GE. 1.65 C----------------------------------------------------------------------- 20 IF (X .GE. 2.0) GO TO 30 FN = ((((PN(1)*Y + PN(2))*Y + PN(3))*Y + PN(4))*Y + PN(5))*Y * + PN(6) FD = ((((PD(1)*Y + PD(2))*Y + PD(3))*Y + PD(4))*Y + PD(5))*Y * + PD(6) GN = ((((QN(1)*Y + QN(2))*Y + QN(3))*Y + QN(4))*Y + QN(5))*Y * + QN(6) GD = ((((QD(1)*Y + QD(2))*Y + QD(3))*Y + QD(4))*Y + QD(5))*Y * + QD(6) F = FN/(X*FD) G = GN/(X*XX*GD) Y = 0.5*XX GO TO 80 C 30 IF (X .GE. 3.0) GO TO 40 FN = ((((AN(1)*Y + AN(2))*Y + AN(3))*Y + AN(4))*Y + AN(5))*Y * + AN(6) FD = ((((AD(1)*Y + AD(2))*Y + AD(3))*Y + AD(4))*Y + AD(5))*Y * + AD(6) GN = ((((BN(1)*Y + BN(2))*Y + BN(3))*Y + BN(4))*Y + BN(5))*Y * + BN(6) GD = ((((BD(1)*Y + BD(2))*Y + BD(3))*Y + BD(4))*Y + BD(5))*Y * + BD(6) F = FN/(X*FD) G = GN/(X*XX*GD) GO TO 70 C 40 FN = (((CN(1)*Y + CN(2))*Y + CN(3))*Y + CN(4))*Y + CN(5) FD = (((CD(1)*Y + CD(2))*Y + CD(3))*Y + CD(4))*Y + CD(5) GN = (((DN(1)*Y + DN(2))*Y + DN(3))*Y + DN(4))*Y + DN(5) GD = (((DD(1)*Y + DD(2))*Y + DD(3))*Y + DD(4))*Y + DD(5) F = FN/(X*FD) G = GN/(X*XX*GD) GO TO 70 C 50 IF (X .GE. 6.0) GO TO 60 XX = X*X Y = 1.0/(XX*XX) F = (((((FP(1)*Y + FP(2))*Y + FP(3))*Y + FP(4))*Y + FP(5))*Y * + FP(6))*Y + FP(7) G = (((((GP(1)*Y + GP(2))*Y + GP(3))*Y + GP(4))*Y + GP(5))*Y * + GP(6))*Y + GP(7) F = F/X G = G/(X*XX) GO TO 70 C 60 IF (X .GE. FLOAT(MAX)) GO TO 100 PIX = PI*X PIXX = PIX*X Y = 1.0/PIXX Y = Y*Y F = ((((P(1)*Y + P(2))*Y + P(3))*Y + P(4))*Y + P(5))*Y + P(6) G = ((((Q(1)*Y + Q(2))*Y + Q(3))*Y + Q(4))*Y + Q(5))*Y + Q(6) F = F/PIX G = G/(PIX*PIXX) C----------------------------------------------------------------------- C EVALUATION OF SIN(0.5*PI*X*X) AND COS(0.5*PI*X*X) C THE RESULTS ARE STORED IN SY AND CY C----------------------------------------------------------------------- 70 M = X L = MOD(M,2) N = M - L Y = X - M R = X - N C Y = Y*N M = Y Y = Y - M IF (MOD(M,2) .NE. 0) Y = (Y - 0.5) - 0.5 Y = Y + 0.5*R*R C 80 SY = SIN1(Y) CY = COS1(Y) C----------------------------------------------------------------------- C TERMINATION C----------------------------------------------------------------------- 90 C = 0.5 + (F*SY - G*CY) S = 0.5 - (F*CY + G*SY) IF (T .GE. 0.0) RETURN C = - C S = - S RETURN C 100 IF (T .LT. 0.0) GO TO 110 C = 0.5 S = 0.5 RETURN 110 C = -0.5 S = -0.5 RETURN END SUBROUTINE CEXPLI (MO, Z, W) C----------------------------------------------------------------------- C EVALUATION OF THE COMPLEX EXPONENTIAL INTEGRAL C----------------------------------------------------------------------- COMPLEX Z, W REAL N, NP1 REAL CD(18), CE(18) REAL QF(2), SM(2), TM(2), TS(2) REAL G0(2), GN(2), H0(2), HN(2), WN(2) LOGICAL IND C------------------------- ANORM(X,Y) = AMAX1(ABS(X),ABS(Y)) C------------------------- DATA PI /3.14159265358979/ DATA EULER /.577215664901533/ C------------------------- DATA CD(1) /0.00000000000000E+00/, CD(2) /.311105957086528E-01/, * CD(3) /.103661260539112E+00/, CD(4) /.216532335244554E+00/, * CD(5) /.369931427960192E+00/, CD(6) /.566766259990589E+00/, * CD(7) /.814042066324748E+00/, CD(8) /.112384247540813E+01/, * CD(9) /.151400478148512E+01/, CD(10) /.200886795032284E+01/, * CD(11) /.264052411823592E+01/, CD(12) /.345098449933392E+01/, * CD(13) /.449583360763202E+01/, CD(14) /.585058263409822E+01/, * CD(15) /.762273501463380E+01/, CD(16) /.997814501584578E+01/, * CD(17) /.132122064896408E+02/, CD(18) /.180322948376021E+02/ DATA CE(1) /.850156516121093E-02/, CE(2) /.505037465849058E-01/, * CE(3) /.836817368956407E-01/, CE(4) /.107047582417607E+00/, * CE(5) /.120424719029462E+00/, CE(6) /.125096631582229E+00/, * CE(7) /.122314435224685E+00/, CE(8) /.112621417553907E+00/, * CE(9) /.963419407392582E-01/, CE(10) /.747398422757511E-01/, * CE(11) /.508596135953441E-01/, CE(12) /.290822706773628E-01/, * CE(13) /.132201640530101E-01/, CE(14) /.443802939829067E-02/, * CE(15) /.992612478987576E-03/, CE(16) /.126579795112011E-03/, * CE(17) /.702150908253350E-05/, CE(18) /.910281532564632E-07/ C------------------------- C C ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE C SMALLEST NUMBER SUCH THAT 1.D0 + EPS .GT. 1.D0. C EPS = SPMPAR(1) C C------------------------- C X = REAL(Z) Y = AIMAG(Z) R = CPABS(X,Y) EPS = AMAX1(EPS,1.E-15) C IF (R .LE. 1.0) GO TO 20 IF (R .GE. 40.0) GO TO 60 IF (R .LT. 4.0) GO TO 10 IF (X .LE. 0.0 .OR. ABS(Y) .GT. 8.0) GO TO 60 IF (R .LT. 10.0 .AND. ABS(Y) .GT. 1.8*X) GO TO 60 GO TO 20 10 IF (X .LT. 0.09*Y*Y) GO TO 50 IF (R .GT. 3.6 .AND. ABS(Y) .GT. 1.8*X) GO TO 60 C C TAYLOR SERIES C 20 SM(1) = 0.0 SM(2) = 0.0 TM(1) = X TM(2) = Y N = 1.0 30 N = N + 1.0 TS(1) = TM(1)*X - TM(2)*Y TS(2) = TM(1)*Y + TM(2)*X TM(1) = TS(1)/N TM(2) = TS(2)/N TS(1) = TM(1)/N TS(2) = TM(2)/N SM(1) = SM(1) + TS(1) SM(2) = SM(2) + TS(2) IF (ANORM(TS(1),TS(2)) .GT. EPS*ANORM(SM(1),SM(2))) * GO TO 30 SM(1) = X + SM(1) SM(2) = Y + SM(2) C SM(1) = (EULER + ALOG(R)) + SM(1) SM(2) = ATAN2(-Y, -X) + SM(2) GO TO 110 C C RATIONAL EXPANSION C 50 SM(1) = 0.0 SM(2) = 0.0 DO 51 I = 1,18 TS(1) = X - CD(I) TS(2) = Y SS = TS(1)*TS(1) + TS(2)*TS(2) SM(1) = SM(1) + CE(I)*TS(1)/SS SM(2) = SM(2) - CE(I)*TS(2)/SS 51 CONTINUE GO TO 100 C C PADE APPROXIMATION FOR THE ASYMPTOTIC EXPANSION C FOR EXP(-Z)*EI(Z) C 60 X = - X Y = - Y D = 4.0*R IF (R .LT. 10.0) D = 32.0 G0(1) = 1.0 G0(2) = 0.0 GN(1) = (1.0 + X)/D GN(2) = Y/D H0(1) = 1.0 H0(2) = 0.0 U = X + 2.0 HN(1) = U/D HN(2) = GN(2) W = CMPLX(1.0 + X, Y)/CMPLX(U,Y) WN(1) = REAL(W) WN(2) = AIMAG(W) NP1 = 1.0 TOL = 4.0*EPS C 70 N = NP1 NP1 = N + 1.0 E = (N*NP1)/D U = U + 2.0 TM(1) = ((U*GN(1) - Y*GN(2)) - E*G0(1))/D TM(2) = ((U*GN(2) + Y*GN(1)) - E*G0(2))/D G0(1) = GN(1) G0(2) = GN(2) GN(1) = TM(1) GN(2) = TM(2) TM(1) = ((U*HN(1) - Y*HN(2)) - E*H0(1))/D TM(2) = ((U*HN(2) + Y*HN(1)) - E*H0(2))/D H0(1) = HN(1) H0(2) = HN(2) HN(1) = TM(1) HN(2) = TM(2) C TM(1) = WN(1) TM(2) = WN(2) W = CMPLX(GN(1),GN(2))/CMPLX(HN(1),HN(2)) WN(1) = REAL(W) WN(2) = AIMAG(W) IF (ANORM(TM(1) - WN(1), TM(2) - WN(2)) .GT. * TOL*ANORM(WN(1), WN(2))) GO TO 70 C X = REAL(Z) Y = AIMAG(Z) W = W/Z SM(1) = REAL(W) SM(2) = AIMAG(W) C C TERMINATION C 100 IND = X .LE. 0.0 .OR. ABS(Y) .GT. 1.E-2 IF (IND .AND. MO .NE. 0) GO TO 130 C = PI IF (Y .GT. 0.0) C = -PI QM = EXP(X) CY = COS(Y) SY = SIN(Y) QF(1) = QM*CY QF(2) = QM*SY IF (MO .EQ. 0) GO TO 120 C R = C/QM SM(1) = SM(1) + R*SY SM(2) = SM(2) + R*CY GO TO 130 C 110 IF (MO .EQ. 0) GO TO 130 IND = .TRUE. QM = EXP(-X) QF(1) = QM*COS(-Y) QF(2) = QM*SIN(-Y) C 120 TS(1) = QF(1)*SM(1) - QF(2)*SM(2) TS(2) = QF(1)*SM(2) + QF(2)*SM(1) SM(1) = TS(1) SM(2) = TS(2) IF (.NOT. IND) SM(2) = SM(2) + C C 130 W = CMPLX(SM(1),SM(2)) RETURN END SUBROUTINE EXPLI(INT,ARG,RESULT,IERR) C REAL A(6),B(5),C(7),D(7),E(7),F(7),P1(8),Q1(8),P2(8),Q2(7), 1 P3(8),Q3(7),P4(8),Q4(7),R(20),PX(9),QX(9), 2 FRAC,SUMP,SUMQ,T,W,X,X0,XX0,XMX0,Y,DEXP40,XMAX, 3 XMIN,EI,ARG,RESULT,EXPARG INTEGER I,INT,IERR DOUBLE PRECISION DX0 C----------------------------------------------------------------------- C C THIS SUBROUTINE COMPUTES THE EXPONENTIAL INTEGRALS C C EI(X), E-SUB-1(X) = -EI(-X), AND EXP(-X)*EI(X) C C WHERE C C INTEGRAL (FROM T=-INFINITY TO T=X) (EXP(T)/T), X .GT. 0, C EI(X) = C -INTEGRAL (FROM T=-X TO T=INFINITY) (EXP(-T)/T), C X .LT. 0, C C AND WHERE THE FIRST INTEGRAL IS A PRINCIPAL VALUE INTEGRAL. THE C ARGUMENTS INT, ARG, AND RESULT HAVE THE FOLLOWING USAGE ... C C INT ARG RESULT C 1 X .NE. 0 EI(X) C 2 X .GT. 0 E-SUB-1(X) C 3 X .NE. 0 EXP(-X)*EI(X) C C THE EXPANSION FOR 4 .LE. X .LE. 8 IS DUE TO WAYNE FULLERTON (LOS C ALAMOS). THE REMAINING EXPANSIONS ARE FROM MATH. COMP. 22, 641-649 C (1968), AND MATH. COMP. 23, 289-303(1969) BY CODY AND THACHER. C C ------------ C C ERROR MONITORING C C THE PARAMETER IERR IS A VARIABLE THAT IS SET BY THE ROUTINE. C IF NO ERRORS ARE DETECTED THEN IERR IS SET TO 0. THE FOLLOWING C TABLE INDICATES THE TYPES OF ERRORS THAT MAY BE ENCOUNTERED IN C THE ROUTINE AND THE FUNCTION VALUES SUPPLIED IN EACH CASE. C C IERR ERROR ARGUMENT FUNCTION VALUES FOR C RANGE EI(X) EXP(-X)*EI(X) E-SUB-1(X) C 1 UNDERFLOW X .LT. XMIN 0 - 0 C 2 OVERFLOW X .GT. XMAX T - - C 3 ILLEGAL X X = 0 T T T C 4 ILLEGAL X X .LT. 0 - - T C C T INDICATES THAT THE ROUTINE TERMINATES WITHOUT ASSIGNING A VALUE C TO THE FUNCTION. C C ---------- C C THIS SUBROUTINE WAS WRITTEN AT ARGONNE NATIONAL LABORATORY FOR C THE FUNPACK PACKAGE OF SPECIAL FUNCTION SUBROUTINES. THE ROUTINE C WAS MODIFIED BY BY A.H. MORRIS (NSWC). C C----------------------------------------------------------------------- C C XMAX AND XMIN ARE MACHINE DEPENDENT CONSTANTS FOR DETECTING C UNDERFLOW AND OVERFLOW. XMAX AND XMIN ARE GIVEN APPROXIMATE C VALUES IN STATEMENTS 240 AND 340. C C----------------------------------------------------------------------- C C VALUE OF EXP(40.0) C C ---------- DATA DEXP40/.235385266837020E+18/ C ---------- C C ZERO OF EI(X) C C ---------- DATA X0/.372507410781366/,DX0/.37250741078136663446199186658D0/ C ---------- C C COEFFICIENTS FOR R(5,4) APPROXIMATION, C USED FOR -1.0 .LE. X .LT. 0.0 C C ---------- DATA A(1)/-.577215664901531E+00/, A(2) /.758833087029943E+00/, * A(3) /.125660818982053E+00/, A(4) /.204158408934305E-01/, * A(5) /.825035122466538E-03/, A(6) /.962949813453924E-05/ DATA B(1) /.100000000000000E+01/, B(2) /.417810755380398E+00/, * B(3) /.730228560396799E-01/, B(4) /.642720224671078E-02/, * B(5) /.245134203588369E-03/ C ---------- C C COEFFICIENTS FOR R(6,6) APPROXIMATION, C USED FOR -4.0 .LE. X .LT. -1.0 C C ---------- DATA C(1) /.465627107975096E-06/, C(2) /.999979577051595E+00/, * C(3) /.904161556946328E+01/, C(4) /.243784088791317E+02/, * C(5) /.230192559391334E+02/, C(6) /.690522522784443E+01/, * C(7) /.430967839469389E+00/ DATA D(1) /.100000000000000E+01/, D(2) /.100411643829054E+02/, * D(3) /.324264210695138E+02/, D(4) /.412807841891424E+02/, * D(5) /.204494785013794E+02/, D(6) /.331909213593302E+01/, * D(7) /.103400130404874E+00/ C ---------- C C COEFFICIENTS FOR R(6,6) APPROXIMATION, C USED FOR X .LT. -4.0 C C ---------- DATA E(1)/-.999999999998447E+00/, E(2)/-.266271060431811E+02/, * E(3)/-.241055827097015E+03/, E(4)/-.895927957772937E+03/, * E(5)/-.129885688746484E+04/, E(6)/-.545374158883133E+03/, * E(7)/-.566575206533869E+01/ DATA F(1) /.100000000000000E+01/, F(2) /.286271060422192E+02/, * F(3) /.292310039388533E+03/, F(4) /.133278537748257E+04/, * F(5) /.277761949509163E+04/, F(6) /.240401713225909E+04/, * F(7) /.631657483280800E+03/ C ---------- C C COEFFICIENTS FOR R(7,7) APPROXIMATION, C IN CHEBYSHEV POLYNOMIAL FORM, USED FOR C 0.0 .LT. X .LT. 4.0 C C ---------- DATA P1(1)/-.866937339951070E+01/, P1(2)/-.549142265521085E+03/, * P1(3)/-.421001615357070E+04/, P1(4)/-.249301393458648E+06/, * P1(5)/-.119623669349247E+06/, P1(6)/-.221744627758845E+08/, * P1(7) /.389280421311201E+07/, P1(8)/-.195773036904548E+09/ DATA Q1(1) /.341718750000000E+02/, Q1(2)/-.160708926587221E+04/, * Q1(3) /.357300298058508E+05/, Q1(4)/-.483547436162164E+06/, * Q1(5) /.428559624611749E+07/, Q1(6)/-.249033375740540E+08/, * Q1(7) /.891925767575612E+08/, Q1(8)/-.826271498626055E+08/ C ---------- C C COEFFICIENTS FOR CHEBYSHEV EXPANSION FOR C 4.0 .LE. X .LE. 8.0 C C ---------- DATA R(1) / .636295897967470E+00/, R(2) /-.130811686750676E+00/, * R(3) /-.843674102130539E-02/, R(4) / .265684915310067E-02/, * R(5) / .328227217816581E-03/, R(6) /-.237834477714302E-04/, * R(7) /-.114398043081001E-04/, R(8) /-.144059434332383E-05/, * R(9) / .524159566511488E-08/, R(10)/ .384073064078443E-07/, * R(11)/ .858802448602672E-08/, R(12)/ .102192266258550E-08/, * R(13)/ .217491323232897E-10/, R(14)/-.220902381426231E-10/, * R(15)/-.634575335449288E-11/, R(16)/-.108377465668577E-11/, * R(17)/-.119098228722226E-12/, R(18)/-.284386823892656E-14/, * R(19)/ .250803270266868E-14/, R(20)/ .787296415285598E-15/ C C COEFFICIENTS FOR R(7,7) APPROXIMATION, C IN J-FRACTION FORM, USED FOR C 8.0 .LT. X .LT. 12.0 C C ---------- DATA P2(1)/-.218086381520723E+01/, P2(2)/-.219010233854881E+02/, * P2(3)/ .930816385662165E+01/, P2(4) /.250762811293560E+02/, * P2(5)/-.331842531997221E+02/, P2(6) /.601217990830080E+02/, * P2(7)/-.432531132878135E+02/, P2(8) /.100443109228078E+01/ DATA Q2(1)/ .393707701852715E+01/, Q2(2) /.300892648372915E+03/, * Q2(3)/-.625041161671876E+01/, Q2(4) /.100367439516726E+04/, * Q2(5)/ .143256738121938E+02/, Q2(6) /.273624119889328E+04/, * Q2(7)/ .527468851962908E+00/ C ---------- C C COEFFICIENTS FOR R(7,7) APPROXIMATION, C IN J-FRACTION FORM, USED FOR C 12.0 .LE. X .LT. 24.0 C C ---------- DATA P3(1)/-.348334653602852E+01/, P3(2)/-.186545454883399E+02/, * P3(3)/-.828561994140641E+01/, P3(4)/-.323467330305403E+02/, * P3(5)/ .179601688769252E+02/, P3(6) /.175656315469614E+01/, * P3(7)/-.195022321289660E+01/, P3(8) /.999994296074708E+00/ DATA Q3(1) /.695000655887434E+02/, Q3(2) /.572837193837324E+02/, * Q3(3) /.257776384238440E+02/, Q3(4) /.760761148007735E+03/, * Q3(5) /.289516727925135E+02/, Q3(6)/-.343942266899870E+01/, * Q3(7) /.100083867402639E+01/ C ---------- C C COEFFICIENTS FOR R(7.7) APPROXIMATION, C IN J-FRACTION FORM, USED FOR X .GE. 24.0 C C ---------- DATA P4(1)/-.531686623494482E+02/, P4(2)/ .891263822573708E+01/, * P4(3)/-.139381360364405E+01/, P4(4)/-.308336269051763E+02/, * P4(5)/-.749289167792884E+01/, P4(6)/-.500140345515924E+01/, * P4(7)/-.300000016782086E+01/, P4(8)/ .100000000000058E+01/ DATA Q4(1)/ .104745362652468E+04/, Q4(2)/-.674704580465832E+01/, * Q4(3)/ .295999399486831E+03/, Q4(4)/-.431325836146628E+01/, * Q4(5)/-.790404992298926E+01/, Q4(6)/-.299996432944446E+01/, * Q4(7)/ .199999999924131E+01/ C----------------------------------------------------------------------- C X = ARG IERR = 0 IF (INT .EQ. 2) GO TO 450 IF (X) 280, 640, 110 110 IF (X .GE. 12.E0) GO TO 200 IF (X .GT. 8.E0) GO TO 160 IF (X .GE. 4.E0) GO TO 150 C ---------- 0.0 .LT. X .LT. 4.0. C RATIONAL APPROXIMATION USED IS EXPRESSED C IN TERMS OF CHEBYSHEV POLYNOMIALS TO C IMPROVE CONDITIONING ---------- T = X + X T = T / 3.0E0 - 2.0E0 PX(1) = 0.0E0 QX(1) = 0.0E0 PX(2) = P1(1) QX(2) = Q1(1) C DO 120 I = 2, 7 PX(I+1) = T * PX(I) - PX(I-1) + P1(I) QX(I+1) = T * QX(I) - QX(I-1) + Q1(I) 120 CONTINUE C SUMP = .5E0 * T * PX(8) - PX(7) + P1(8) SUMQ = .5E0 * T * QX(8) - QX(7) + Q1(8) FRAC = SUMP / SUMQ XMX0 = DBLE(X) - DX0 IF (ABS(XMX0) .LT. 0.07E0) GO TO 140 XX0 = X / X0 EI = ALOG(XX0) + XMX0 * FRAC IF (INT .EQ. 3) EI = EXP(-X) * EI GO TO 410 C ---------- EVALUATE APPROXIMATION FOR LN(X/X0) C FOR X CLOSE TO X0 ---------- 140 Y = XMX0 / X0 EI = ALNREL(Y) + XMX0 * FRAC IF (INT .EQ. 3) EI = EXP(-X) * EI GO TO 410 C ---------- 4.0 .LE. X .LE. 8.0 ---------- 150 M = 20 EI = (1.0 + CSEVL (3.0 - 16.0/X, R, M)) / X IF (INT .EQ. 3) GO TO 410 EI = EI * EXP(X) GO TO 410 C ---------- 8.0 .LT. X .LT. 12.0 ---------- 160 FRAC = 0.0E0 C DO 180 I = 1, 7 180 FRAC = Q2(I) / (P2(I) + X + FRAC) C EI = (P2(8) + FRAC) / X IF (INT .EQ. 3) GO TO 410 EI = EI * EXP(X) GO TO 410 C ---------- 12.0 .LE. X .LT. 24.0 ---------- 200 IF (X .GE. 24.E0) GO TO 240 FRAC = 0.0E0 C DO 220 I = 1, 7 220 FRAC = Q3(I) / (P3(I) + X + FRAC) C EI = (P3(8) + FRAC) / X IF (INT .EQ. 3) GO TO 410 EI = EI * EXP(X) GO TO 410 C ---------- 24.0 .LE. X ---------- 240 XMAX = EXPARG(0) IF ((X .GT. XMAX) .AND. (INT .LT. 3)) GO TO 620 Y = 1.0E0 / X FRAC = 0.0E0 C DO 260 I = 1, 7 260 FRAC = Q4(I) / (P4(I) + X + FRAC) C FRAC = P4(8) + FRAC EI = Y + Y * Y * FRAC IF (INT .EQ. 3) GO TO 410 IF (X .GT. 150.0E0) GO TO 270 EI = EI * EXP(X) GO TO 410 C ---------- CALCULATION REFORMULATED TO AVOID C PREMATURE OVERFLOW ---------- 270 EI = (EI * EXP(X-40.0E0)) * DEXP40 GO TO 410 C ---------- ORIGINAL X WAS NEGATIVE. CALCULATION OF C E-SUB-1 JOINS AT LABEL 300 ---------- 280 Y = -X 300 W = 1.0E0 / Y IF (Y .GT. 4.0E0) GO TO 340 IF (Y .GT. 1.0E0) GO TO 320 C ---------- 0.0 .LT. -X .LE. 1.0 ---------- EI = ALOG(Y) - (((((A(6) * Y + A(5)) * Y + A(4)) 1 * Y + A(3)) * Y + A(2)) * Y + A(1)) / 2 ((((B(5) * Y + B(4)) * Y + B(3)) 3 * Y + B(2)) * Y + B(1)) IF (INT .EQ. 3) EI = EI * EXP(Y) GO TO 400 C ---------- 1.0 .LT. -X .LE. 4.0 ---------- 320 EI = -((((((C(7) * W + C(6)) * W + C(5)) * W + C(4)) 1 * W + C(3)) * W + C(2)) * W + C(1)) / 2 ((((((D(7) * W + D(6)) * W + D(5)) * W + D(4)) 3 * W + D(3)) * W + D(2)) * W + D(1)) IF (INT .EQ. 3) GO TO 410 EI = EI * EXP(-Y) GO TO 400 C ---------- 4.0 .LT. -X ---------- 340 XMIN = EXPARG(1) IF ((-ABS(X) .LT. XMIN) .AND. (INT .LT. 3)) GO TO 600 EI = -W * (1.0E0 + W * ((((((E(7) 1 * W + E(6)) * W + E(5)) * W + E(4)) 2 * W + E(3)) * W + E(2)) * W + E(1)) / 3 ((((((F(7) * W + F(6)) * W + F(5)) 4 * W + F(4)) * W + F(3)) * W + F(2)) * W + F(1))) IF (INT .EQ. 3) GO TO 410 EI = EI * EXP(-Y) T = 0.5E0 * EI IF (T .EQ. 0.0E0) GO TO 600 400 IF (INT .EQ. 2) EI = -EI 410 RESULT = EI RETURN 450 Y = X IF (Y) 660, 640, 300 C ---------- ERROR RETURN FOR X .LT. XMIN, C CAUSING UNDERFLOW ---------- 600 EI = 0.0E0 IERR = 1 GO TO 410 C ---------- ERROR RETURN FOR X .GT. XMAX, C CAUSING OVERFLOW ---------- 620 IERR = 2 RETURN C ---------- ERROR RETURN FOR ILLEGAL C ARGUMENT, X = 0 ---------- 640 IERR = 3 RETURN C ---------- ERROR RETURN FOR NEGATIVE C ARGUMENT IN E-SUB-1 ---------- 660 IERR = 4 RETURN END DOUBLE PRECISION FUNCTION DEI (X) C----------------------------------------------------------------------- C DOUBLE PRECISION EVALUATION OF THE EXPONENTIAL INTEGRAL C----------------------------------------------------------------------- DOUBLE PRECISION X DOUBLE PRECISION DE1E C DEI = -DE1E(-X) IF (X .GT. 4.D0 .OR. X .LT. -1.D0) DEI = DEXP(X) * DEI RETURN END DOUBLE PRECISION FUNCTION DEI1 (X) C----------------------------------------------------------------------- C DOUBLE PRECISION EVALUATION OF EXP(-X)*EI(X) C----------------------------------------------------------------------- DOUBLE PRECISION X DOUBLE PRECISION DE1E C DEI1 = -DE1E(-X) IF (X .GT. 4.D0 .OR. X .LT. -1.D0) RETURN DEI1 = DEXP(-X) * DEI1 RETURN END DOUBLE PRECISION FUNCTION DE1E(X) C----------------------------------------------------------------------- C C LET E1(X) DENOTE THE EXPONENTIAL INTEGRAL FOR POSITIVE X AND C THE CAUCHY PRINCIPAL VALUE FOR NEGATIVE X. IF X IS NONZERO C THEN DE1E HAS THE VALUE ... C C DE1E(X) = E1(X) IF -4 .LE. X .LE. 1 C DE1E(X) = EXP(X)*E1(X) OTHERWISE C C----------------------------------------------------------------------- C WRITTEN BY ALFRED H. MORRIS, JR. C NAVAL SURFACE WARFARE CENTER C DAHLGREN, VIRGINIA C----------------------------------------------------------------------- C C THE FOLLOWING SERIES FOR E1 WERE DEVELOPED BY WAYNE FULLERTON C (LOS ALAMOS NATIONAL LABORATORY). C C SERIES A ON THE INTERVAL -3.12500E-02 TO 0. C WITH WEIGHTED ERROR 4.62E-32 C LOG WEIGHTED ERROR 31.34 C SIGNIFICANT FIGURES REQUIRED 29.70 C DECIMAL PLACES REQUIRED 32.18 C C C SERIES B ON THE INTERVAL -1.25000E-01 TO -3.12500E-02 C WITH WEIGHTED ERROR 2.22E-32 C LOG WEIGHTED ERROR 31.65 C SIGNIFICANT FIGURES REQUIRED 30.75 C DECIMAL PLACES REQUIRED 32.54 C C C SERIES D ON THE INTERVAL -2.50000E-01 TO -1.25000E-01 C WITH WEIGHTED ERROR 5.19E-32 C LOG WEIGHTED ERROR 31.28 C SIGNIFICANT FIGURES REQUIRED 30.82 C DECIMAL PLACES REQUIRED 32.09 C C C SERIES E ON THE INTERVAL -4.00000E+00 TO -1.00000E+00 C WITH WEIGHTED ERROR 8.49E-34 C LOG WEIGHTED ERROR 33.07 C SIGNIFICANT FIGURES REQUIRED 34.13 C DECIMAL PLACES REQUIRED 33.80 C C C SERIES R ON THE INTERVAL -1.00000E+00 TO 1.00000E+00 C WITH WEIGHTED ERROR 8.08E-33 C LOG WEIGHTED ERROR 32.09 C APPROX SIGNIFICANT FIGURES REQUIRED 30.4 C DECIMAL PLACES REQUIRED 32.79 C C C SERIES P ON THE INTERVAL 2.50000E-01 TO 1.00000E+00 C WITH WEIGHTED ERROR 6.65E-32 C LOG WEIGHTED ERROR 31.18 C SIGNIFICANT FIGURES REQUIRED 30.69 C DECIMAL PLACES REQUIRED 32.03 C C C SERIES Q ON THE INTERVAL 0. TO 2.50000E-01 C WITH WEIGHTED ERROR 5.07E-32 C LOG WEIGHTED ERROR 31.30 C SIGNIFICANT FIGURES REQUIRED 30.40 C DECIMAL PLACES REQUIRED 32.20 C C----------------------------------------------------------------------- DOUBLE PRECISION X, C, EPS, T, W DOUBLE PRECISION A(50), B(60), D(41), E(29), R(25), P(50), Q(64) DOUBLE PRECISION DEI0, DCSEVL, DPMPAR C------------------------------ DATA A(1) / .3284394579616699087873844201881D-01/, * A(2) /-.1669920452031362851476184343387D-01/, * A(3) / .2845284724361346807424899853252D-03/, * A(4) /-.7563944358516206489487866938533D-05/, * A(5) / .2798971289450859157504843180879D-06/, * A(6) /-.1357901828534531069525563926255D-07/, * A(7) / .8343596202040469255856102904906D-09/, * A(8) /-.6370971727640248438275242988532D-10/, * A(9) / .6007247608811861235760831561584D-11/, * A(10) /-.7022876174679773590750626150088D-12/ DATA A(11) / .1018302673703687693096652346883D-12/, * A(12) /-.1761812903430880040406309966422D-13/, * A(13) / .3250828614235360694244030353877D-14/, * A(14) /-.5071770025505818678824872259044D-15/, * A(15) / .1665177387043294298172486084156D-16/, * A(16) / .3166753890797514400677003536555D-16/, * A(17) /-.1588403763664141515133118343538D-16/, * A(18) / .4175513256138018833003034618484D-17/, * A(19) /-.2892347749707141906710714478852D-18/, * A(20) /-.2800625903396608103506340589669D-18/ DATA A(21) / .1322938639539270903707580023781D-18/, * A(22) /-.1804447444177301627283887833557D-19/, * A(23) /-.7905384086522616076291644817604D-20/, * A(24) / .4435711366369570103946235838027D-20/, * A(25) /-.4264103994978120868865309206555D-21/, * A(26) /-.3920101766937117541553713162048D-21/, * A(27) / .1527378051343994266343752326971D-21/, * A(28) / .1024849527049372339310308783117D-22/, * A(29) /-.2134907874771433576262711405882D-22/, * A(30) / .3239139475160028267061694700366D-23/ DATA A(31) / .2142183762299889954762643168296D-23/, * A(32) /-.8234609419601018414700348082312D-24/, * A(33) /-.1524652829645809479613694401140D-24/, * A(34) / .1378208282460639134668480364325D-24/, * A(35) / .2131311202833947879523224999253D-26/, * A(36) /-.2012649651526484121817466763127D-25/, * A(37) / .1995535662263358016106311782673D-26/, * A(38) / .2798995808984003464948686520319D-26/, * A(39) /-.5534511845389626637640819277823D-27/, * A(40) /-.3884995396159968861682544026146D-27/ DATA A(41) / .1121304434507359382850680354679D-27/, * A(42) / .5566568152423740948256563833514D-28/, * A(43) /-.2045482929810499700448533938176D-28/, * A(44) /-.8453813992712336233411457493674D-29/, * A(45) / .3565758433431291562816111116287D-29/, * A(46) / .1383653872125634705539949098871D-29/, * A(47) /-.6062167864451372436584533764778D-30/, * A(48) /-.2447198043989313267437655119189D-30/, * A(49) / .1006850640933998348011548180480D-30/, * A(50) / .4623685555014869015664341461674D-31/ C------------------------------ DATA B(1) / .20263150647078889499401236517381D+00/, * B(2) /-.73655140991203130439536898728034D-01/, * B(3) / .63909349118361915862753283840020D-02/, * B(4) /-.60797252705247911780653153363999D-03/, * B(5) /-.73706498620176629330681411493484D-04/, * B(6) / .48732857449450183453464992488076D-04/, * B(7) /-.23837064840448290766588489460235D-05/, * B(8) /-.30518612628561521027027332246121D-05/, * B(9) / .17050331572564559009688032992907D-06/, * B(10) / .23834204527487747258601598136403D-06/ DATA B(11) / .10781772556163166562596872364020D-07/, * B(12) /-.17955692847399102653642691446599D-07/, * B(13) /-.41284072341950457727912394640436D-08/, * B(14) / .68622148588631968618346844526664D-09/, * B(15) / .53130183120506356147602009675961D-09/, * B(16) / .78796880261490694831305022893515D-10/, * B(17) /-.26261762329356522290341675271232D-10/, * B(18) /-.15483687636308261963125756294100D-10/, * B(19) /-.25818962377261390492802405122591D-11/, * B(20) / .59542879191591072658903529959352D-12/ DATA B(21) / .46451400387681525833784919321405D-12/, * B(22) / .11557855023255861496288006203731D-12/, * B(23) /-.10475236870835799012317547189670D-14/, * B(24) /-.11896653502709004368104489260929D-13/, * B(25) /-.47749077490261778752643019349950D-14/, * B(26) /-.81077649615772777976249734754135D-15/, * B(27) / .13435569250031554199376987998178D-15/, * B(28) / .14134530022913106260248873881287D-15/, * B(29) / .49451592573953173115520663232883D-16/, * B(30) / .79884048480080665648858587399367D-17/ DATA B(31) /-.14008632188089809829248711935393D-17/, * B(32) /-.14814246958417372107722804001680D-17/, * B(33) /-.55826173646025601904010693937113D-18/, * B(34) /-.11442074542191647264783072544598D-18/, * B(35) / .25371823879566853500524018479923D-20/, * B(36) / .13205328154805359813278863389097D-19/, * B(37) / .62930261081586809166287426789485D-20/, * B(38) / .17688270424882713734999261332548D-20/, * B(39) / .23266187985146045209674296887432D-21/, * B(40) /-.67803060811125233043773831844113D-22/ DATA B(41) /-.59440876959676373802874150531891D-22/, * B(42) /-.23618214531184415968532592503466D-22/, * B(43) /-.60214499724601478214168478744576D-23/, * B(44) /-.65517906474348299071370444144639D-24/, * B(45) / .29388755297497724587042038699349D-24/, * B(46) / .22601606200642115173215728758510D-24/, * B(47) / .89534369245958628745091206873087D-25/, * B(48) / .24015923471098457555772067457706D-25/, * B(49) / .34118376888907172955666423043413D-26/, * B(50) /-.71617071694630342052355013345279D-27/ DATA B(51) /-.75620390659281725157928651980799D-27/, * B(52) /-.33774612157467324637952920780800D-27/, * B(53) /-.10479325703300941711526430332245D-27/, * B(54) /-.21654550252170342240854880201386D-28/, * B(55) /-.75297125745288269994689298432000D-30/, * B(56) / .19103179392798935768638084000426D-29/, * B(57) / .11492104966530338547790728833706D-29/, * B(58) / .43896970582661751514410359193600D-30/, * B(59) / .12320883239205686471647157725866D-30/, * B(60) / .22220174457553175317538581162666D-31/ C------------------------------ DATA D(1) / .63629589796747038767129887806803D+00/, * D(2) /-.13081168675067634385812671121135D+00/, * D(3) /-.84367410213053930014487662129752D-02/, * D(4) / .26568491531006685413029428068906D-02/, * D(5) / .32822721781658133778792170142517D-03/, * D(6) /-.23783447771430248269579807851050D-04/, * D(7) /-.11439804308100055514447076797047D-04/, * D(8) /-.14405943433238338455239717699323D-05/, * D(9) / .52415956651148829963772818061664D-08/, * D(10) / .38407306407844323480979203059716D-07/ DATA D(11) / .85880244860267195879660515759344D-08/, * D(12) / .10219226625855003286339969553911D-08/, * D(13) / .21749132323289724542821339805992D-10/, * D(14) /-.22090238142623144809523503811741D-10/, * D(15) /-.63457533544928753294383622208801D-11/, * D(16) /-.10837746566857661115340539732919D-11/, * D(17) /-.11909822872222586730262200440277D-12/, * D(18) /-.28438682389265590299508766008661D-14/, * D(19) / .25080327026686769668587195487546D-14/, * D(20) / .78729641528559842431597726421265D-15/ DATA D(21) / .15475066347785217148484334637329D-15/, * D(22) / .22575322831665075055272608197290D-16/, * D(23) / .22233352867266608760281380836693D-17/, * D(24) / .16967819563544153513464194662399D-19/, * D(25) /-.57608316255947682105310087304533D-19/, * D(26) /-.17591235774646878055625369408853D-19/, * D(27) /-.36286056375103174394755328682666D-20/, * D(28) /-.59235569797328991652558143488000D-21/, * D(29) /-.76030380926310191114429136895999D-22/, * D(30) /-.62547843521711763842641428479999D-23/ DATA D(31) / .25483360759307648606037606400000D-24/, * D(32) / .25598615731739857020168874666666D-24/, * D(33) / .71376239357899318800207052800000D-25/, * D(34) / .14703759939567568181578956800000D-25/, * D(35) / .25105524765386733555198634666666D-26/, * D(36) / .35886666387790890886583637333333D-27/, * D(37) / .39886035156771301763317759999999D-28/, * D(38) / .21763676947356220478805333333333D-29/, * D(39) /-.46146998487618942367607466666666D-30/, * D(40) /-.20713517877481987707153066666666D-30/ DATA D(41) /-.51890378563534371596970666666666D-31/ C------------------------------ DATA E(1) /-.16113461655571494025720663927566180D+02/, * E(2) / .77940727787426802769272245891741497D+01/, * E(3) /-.19554058188631419507127283812814491D+01/, * E(4) / .37337293866277945611517190865690209D+00/, * E(5) /-.56925031910929019385263892220051166D-01/, * E(6) / .72110777696600918537847724812635813D-02/, * E(7) /-.78104901449841593997715184089064148D-03/, * E(8) / .73880933562621681878974881366177858D-04/, * E(9) /-.62028618758082045134358133607909712D-05/, * E(10) / .46816002303176735524405823868362657D-06/ DATA E(11) /-.32092888533298649524072553027228719D-07/, * E(12) / .20151997487404533394826262213019548D-08/, * E(13) /-.11673686816697793105356271695015419D-09/, * E(14) / .62762706672039943397788748379615573D-11/, * E(15) /-.31481541672275441045246781802393600D-12/, * E(16) / .14799041744493474210894472251733333D-13/, * E(17) /-.65457091583979673774263401588053333D-15/, * E(18) / .27336872223137291142508012748799999D-16/, * E(19) /-.10813524349754406876721727624533333D-17/, * E(20) / .40628328040434303295300348586666666D-19/ DATA E(21) /-.14535539358960455858914372266666666D-20/, * E(22) / .49632746181648636830198442666666666D-22/, * E(23) /-.16208612696636044604866560000000000D-23/, * E(24) / .50721448038607422226431999999999999D-25/, * E(25) /-.15235811133372207813973333333333333D-26/, * E(26) / .44001511256103618696533333333333333D-28/, * E(27) /-.12236141945416231594666666666666666D-29/, * E(28) / .32809216661066001066666666666666666D-31/, * E(29) /-.84933452268306432000000000000000000D-33/ C------------------------------ DATA R(1) /-.3739021479220279511668698204827D-01/, * R(2) / .4272398606220957726049179176528D-01/, * R(3) /-.130318207984970054415392055219726D+00/, * R(4) / .144191240246988907341095893982137D-01/, * R(5) /-.134617078051068022116121527983553D-02/, * R(6) / .107310292530637799976115850970073D-03/, * R(7) /-.742999951611943649610283062223163D-05/, * R(8) / .453773256907537139386383211511827D-06/, * R(9) /-.247641721139060131846547423802912D-07/, * R(10) / .122076581374590953700228167846102D-08/ DATA R(11) /-.548514148064092393821357398028261D-10/, * R(12) / .226362142130078799293688162377002D-11/, * R(13) /-.863589727169800979404172916282240D-13/, * R(14) / .306291553669332997581032894881279D-14/, * R(15) /-.101485718855944147557128906734933D-15/, * R(16) / .315482174034069877546855328426666D-17/, * R(17) /-.923604240769240954484015923200000D-19/, * R(18) / .255504267970814002440435029333333D-20/, * R(19) /-.669912805684566847217882453333333D-22/, * R(20) / .166925405435387319431987199999999D-23/ DATA R(21) /-.396254925184379641856000000000000D-25/, * R(22) / .898135896598511332010666666666666D-27/, * R(23) /-.194763366993016433322666666666666D-28/, * R(24) / .404836019024630033066666666666666D-30/, * R(25) /-.807981567699845120000000000000000D-32/ C------------------------------ DATA P(1) /-.60577324664060345999319382737747D+00/, * P(2) /-.11253524348366090030649768852718D+00/, * P(3) / .13432266247902779492487859329414D-01/, * P(4) /-.19268451873811457249246838991303D-02/, * P(5) / .30911833772060318335586737475368D-03/, * P(6) /-.53564132129618418776393559795147D-04/, * P(7) / .98278128802474923952491882717237D-05/, * P(8) /-.18853689849165182826902891938910D-05/, * P(9) / .37494319356894735406964042190531D-06/, * P(10) /-.76823455870552639273733465680556D-07/ DATA P(11) / .16143270567198777552956300060868D-07/, * P(12) /-.34668022114907354566309060226027D-08/, * P(13) / .75875420919036277572889747054114D-09/, * P(14) /-.16886433329881412573514526636703D-09/, * P(15) / .38145706749552265682804250927272D-10/, * P(16) /-.87330266324446292706851718272334D-11/, * P(17) / .20236728645867960961794311064330D-11/, * P(18) /-.47413283039555834655210340820160D-12/, * P(19) / .11221172048389864324731799928920D-12/, * P(20) /-.26804225434840309912826809093395D-13/ DATA P(21) / .64578514417716530343580369067212D-14/, * P(22) /-.15682760501666478830305702849194D-14/, * P(23) / .38367865399315404861821516441408D-15/, * P(24) /-.94517173027579130478871048932556D-16/, * P(25) / .23434812288949573293896666439133D-16/, * P(26) /-.58458661580214714576123194419882D-17/, * P(27) / .14666229867947778605873617419195D-17/, * P(28) /-.36993923476444472706592538274474D-18/, * P(29) / .93790159936721242136014291817813D-19/, * P(30) /-.23893673221937873136308224087381D-19/ DATA P(31) / .61150624629497608051934223837866D-20/, * P(32) /-.15718585327554025507719853288106D-20/, * P(33) / .40572387285585397769519294491306D-21/, * P(34) /-.10514026554738034990566367122773D-21/, * P(35) / .27349664930638667785806003131733D-22/, * P(36) /-.71401604080205796099355574271999D-23/, * P(37) / .18705552432235079986756924211199D-23/, * P(38) /-.49167468166870480520478020949333D-24/, * P(39) / .12964988119684031730916087125333D-24/, * P(40) /-.34292515688362864461623940437333D-25/ DATA P(41) / .90972241643887034329104820906666D-26/, * P(42) /-.24202112314316856489934847999999D-26/, * P(43) / .64563612934639510757670475093333D-27/, * P(44) /-.17269132735340541122315987626666D-27/, * P(45) / .46308611659151500715194231466666D-28/, * P(46) /-.12448703637214131241755170133333D-28/, * P(47) / .33544574090520678532907007999999D-29/, * P(48) /-.90598868521070774437543935999999D-30/, * P(49) / .24524147051474238587273216000000D-30/, * P(50) /-.66528178733552062817107967999999D-31/ C------------------------------ DATA Q(1) /-.1892918000753016825495679942820D+00/, * Q(2) /-.8648117855259871489968817056824D-01/, * Q(3) / .7224101543746594747021514839184D-02/, * Q(4) /-.8097559457557386197159655610181D-03/, * Q(5) / .1099913443266138867179251157002D-03/, * Q(6) /-.1717332998937767371495358814487D-04/, * Q(7) / .2985627514479283322825342495003D-05/, * Q(8) /-.5659649145771930056560167267155D-06/, * Q(9) / .1152680839714140019226583501663D-06/, * Q(10) /-.2495030440269338228842128765065D-07/ DATA Q(11) / .5692324201833754367039370368140D-08/, * Q(12) /-.1359957664805600338490030939176D-08/, * Q(13) / .3384662888760884590184512925859D-09/, * Q(14) /-.8737853904474681952350849316580D-10/, * Q(15) / .2331588663222659718612613400470D-10/, * Q(16) /-.6411481049213785969753165196326D-11/, * Q(17) / .1812246980204816433384359484682D-11/, * Q(18) /-.5253831761558460688819403840466D-12/, * Q(19) / .1559218272591925698855028609825D-12/, * Q(20) /-.4729168297080398718476429369466D-13/ DATA Q(21) / .1463761864393243502076199493808D-13/, * Q(22) /-.4617388988712924102232173623604D-14/, * Q(23) / .1482710348289369323789239660371D-14/, * Q(24) /-.4841672496239229146973165734417D-15/, * Q(25) / .1606215575700290408116571966188D-15/, * Q(26) /-.5408917538957170947895023784252D-16/, * Q(27) / .1847470159346897881370231402310D-16/, * Q(28) /-.6395830792759094470500610425050D-17/, * Q(29) / .2242780721699759457250233276170D-17/, * Q(30) /-.7961369173983947552744555308646D-18/ DATA Q(31) / .2859308111540197459808619929272D-18/, * Q(32) /-.1038450244701137145900697137446D-18/, * Q(33) / .3812040607097975780866841008319D-19/, * Q(34) /-.1413795417717200768717562723696D-19/, * Q(35) / .5295367865182740958305442594815D-20/, * Q(36) /-.2002264245026825902137211131439D-20/, * Q(37) / .7640262751275196014736848610918D-21/, * Q(38) /-.2941119006868787883311263523362D-21/, * Q(39) / .1141823539078927193037691483586D-21/, * Q(40) /-.4469308475955298425247020718489D-22/ DATA Q(41) / .1763262410571750770630491408520D-22/, * Q(42) /-.7009968187925902356351518262340D-23/, * Q(43) / .2807573556558378922287757507515D-23/, * Q(44) /-.1132560944981086432141888891562D-23/, * Q(45) / .4600574684375017946156764233727D-24/, * Q(46) /-.1881448598976133459864609148108D-24/, * Q(47) / .7744916111507730845444328478037D-25/, * Q(48) /-.3208512760585368926702703826261D-25/, * Q(49) / .1337445542910839760619930421384D-25/, * Q(50) /-.5608671881802217048894771735210D-26/ DATA Q(51) / .2365839716528537483710069473279D-26/, * Q(52) /-.1003656195025305334065834526856D-26/, * Q(53) / .4281490878094161131286642556927D-27/, * Q(54) /-.1836345261815318199691326958250D-27/, * Q(55) / .7917798231349540000097468678144D-28/, * Q(56) /-.3431542358742220361025015775231D-28/, * Q(57) / .1494705493897103237475066008917D-28/, * Q(58) /-.6542620279865705439739042420053D-29/, * Q(59) / .2877581395199171114340487353685D-29/, * Q(60) /-.1271557211796024711027981200042D-29/ DATA Q(61) / .5644615555648722522388044622506D-30/, * Q(62) /-.2516994994284095106080616830293D-30/, * Q(63) / .1127259818927510206370368804181D-30/, * Q(64) /-.5069814875800460855562584719360D-31/ C------------------------------ C C ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE C SMALLEST NUMBER SUCH THAT 1.D0 + EPS .GT. 1.D0. C EPS = DPMPAR(1) C C------------------------------ IF (DABS(X) .GE. 90.D0) GO TO 80 IF (X .GT. -1.D0) GO TO 40 C C -90 .LT. X .LT. -4 C IF (X .GT. -32.D0) GO TO 10 M = 50 IF (EPS .GE. 1.D-20) M = 25 DE1E = (1.D0 + DCSEVL (64.D0/X+1.D0, A, M))/X RETURN C 10 IF (X .GT. -8.D0) GO TO 20 M = 60 IF (EPS .GE. 1.D-20) M = 37 DE1E = (1.D0 + DCSEVL ((64.D0/X+5.D0)/3.D0, B, M))/X RETURN C 20 IF (X .GE. -4.D0) GO TO 30 M = 41 IF (EPS .GE. 1.D-20) M = 27 DE1E = (1.D0 + DCSEVL (16.D0/X+3.D0, D, M))/X RETURN C C -4 .LE. X .LE. 1 C 30 M = 29 IF (EPS .GE. 1.D-20) M = 20 DE1E = -DLOG(-X) + DCSEVL ((2.D0*X+5.D0)/3.D0, E, M) RETURN C 40 IF (X .GT. 1.0D0) GO TO 60 IF (X .LT. -0.4D0 .OR. X .GT. -0.35D0) GO TO 50 DE1E = - DEI0(-X, EPS) RETURN 50 M = 25 IF (EPS .GE. 1.D-20) M = 18 DE1E = (-DLOG(DABS(X)) - 0.6875D0 + X) + DCSEVL (X, R, M) RETURN C C 1 .LT. X .LT. 90 C 60 IF (X .GT. 4.0D0) GO TO 70 M = 50 IF (EPS .GE. 1.D-20) M = 31 DE1E = (1.D0 + DCSEVL ((8.D0/X-5.D0)/3.D0, P, M))/X RETURN C 70 M = 64 IF (EPS .GE. 1.D-20) M = 35 DE1E = (1.D0 + DCSEVL (8.D0/X-1.D0, Q, M))/X RETURN C C ASYMPTOTIC EXPANSION C 80 T = -1.D0/X C = T W = C M = 1 81 M = M + 1 C = (M*T)*C W = C + W IF (DABS(C) .GT. EPS) GO TO 81 DE1E = (1.D0 + W)/X RETURN END DOUBLE PRECISION FUNCTION DEI0 (X, EPS) C----------------------------------------------------------------------- C C TAYLOR SERIES EXPANSION OF EI(X) AROUND X0, C WHERE X0 IS THE ZERO OF EI(X). C EPS IS THE TOLERANCE USED. C C------------------------- C WRITTEN BY A.H. MORRIS C NAVAL SURFACE WARFARE CENTER C DAHLGREN, VIRGINIA C----------------------------------------------------------------------- DOUBLE PRECISION A(40), C, EPS, H, T, X, W DOUBLE PRECISION DK1, DK2, DK3, DB, DB2, DX C------------------------- DATA DK1 /25598514349.D0/, DK2 /12212826724.D0/, * DK3 /52346020729.D0/ DATA DB /68719476736.D0/ DATA DX /.64725688445954142292644880487403537155379408215561D-33/ C------------------------- DATA A(1) / .3896215733907167310156502703593482682018D+01/, * A(2) /-.3281607866398561670879044070702055058438D+01/, * A(3) / .6522376145438925697728352767902339522245D+01/, * A(4) /-.1296969738353651703636356975116693457132D+02/, * A(5) / .2788629796294204997855360701398702087604D+02/, * A(6) /-.6237880152891541873078526672920295283143D+02/, * A(7) / .1435349488096750987841265647073135861344D+03/, * A(8) /-.3371558271787468916821364466977375583658D+03/, * A(9) / .8045318399821382506595322457265602778098D+03/, * A(10) /-.1943796645723498840655451915157946462648D+04/ DATA A(11) / .4743765650402430835228269085129777320454D+04/, * A(12) /-.1167346399116716364394668734600584330571D+05/, * A(13) / .2892695530543545087445160311373446386859D+05/, * A(14) /-.7210794586837158996878001987822898188198D+05/, * A(15) / .1806695585893919626172098163733836311447D+06/, * A(16) /-.4546962188544665746524572520110515778526D+06/, * A(17) / .1148834546817744310374556891236080193473D+07/, * A(18) /-.2912721663850837498392234670693435881386D+07/, * A(19) / .7407692958000587759747953639495510375408D+07/, * A(20) /-.1889172700038153127288849726417780854730D+08/ DATA A(21) / .4830003493086024720868271496253148288055D+08/, * A(22) /-.1237682190024917092137405370407916520821D+09/, * A(23) / .3178111056663621852260468265468336116367D+09/, * A(24) /-.8176185693184928170769596413793786736279D+09/, * A(25) / .2107109291864363741291032089276432438927D+10/, * A(26) /-.5438996831077284596300440196418865401363D+10/, * A(27) / .1406026390995585037838894210474681627693D+11/, * A(28) /-.3639689100149205333626392754168250384373D+11/, * A(29) / .9433859509219164512733865811047107199412D+11/, * A(30) /-.2448111705066430130314746602027041462835D+12/ DATA A(31) / .6359981818273706257655285041587660739835D+12/, * A(32) /-.1653989211524391716301960841541179924503D+13/, * A(33) / .4305601123377464671923711939926758523701D+13/, * A(34) /-.1121847693567642152208443795868288937687D+14/, * A(35) / .2925565695557339262045727352754930716608D+14/, * A(36) /-.7635552741959392076619218035480359307499D+14/, * A(37) / .1994372792759425025753893705017248674884D+15/, * A(38) /-.5213021921201092276891722450906568692592D+15/, * A(39) / .1363558024737805584657706536660107687818D+16/, * A(40) /-.3568973490569445692988895507297245137908D+16/ C------------------------- C C SET H = X - X0 WHERE X0 IS THE ZERO OF EI(X). X0 HAS THE C APPROXIMATE 60 DIGIT VALUE ... C C .37250741078136663446 19918665801191335356 89497771654051555657 C C A MORE ACCURATE VALUE IS GIVEN BY ... C C X0 = DK1/8**12 + DK2/8**24 + DK3/8**36 + DX C C THE FOLLOWING CODE SHOULD YIELD THE CORRECT VALUE FOR H IF A C BINARY, OCTAL, OR HEXADECIMAL DOUBLE PRECISION ARITHMETIC IS C BEING USED. C DB2 = DB*DB H = (((X - DK1/DB) - DK2/DB2) - DK3/(DB*DB2)) - DX C C------------------------- T = H W = 0.D0 DO 10 N = 2,40 C = A(N)*T W = W + C IF (DABS(C) .LT. EPS) GO TO 20 T = H*T 10 CONTINUE C 20 DEI0 = H * (A(1) + W) RETURN END FUNCTION SI(X) C C WRITTEN BY D.E. AMOS AND S.L. DANIEL, NOVEMBER,1975. C MODIFIED BY A.H. MORRIS C C REFERENCES C SAND76-006C C THE SPECIAL FUNCTIONS AND THEIR APPROXIMATIONS, VOL. II, BY C Y.L. LUKE. ACADEMIC PRESS, NEW YORK, 1969. C C ABSTRACT C SI COMPUTES THE INTEGRAL OF SIN(T)/T ON (0,X) BY MEANS C OF CHEBYSHEV EXPANSIONS ON (0,5) AND (5,INFINITY). C C DESCRIPTION OF ARGUMENTS C C INPUT C X - LIMIT OF INTEGRATION, UNRESTRICTED C C OUTPUT C SI - VALUE OF THE INTEGRAL C C DIMENSION BB(16),CC(46) C ------------------- DATA N1,N2,M1,M2/16,46,14,21/ DATA PIO2/1.5707963267949/ C ------------------- DATA BB(1) / 6.84101190850653E-01/, BB(2) /-3.74538448460062E-01/, 1 BB(3) /-2.82656062651542E-02/, BB(4) / 3.06078454012071E-02/, 2 BB(5) /-8.99242948380352E-04/, BB(6) /-1.09884251456048E-03/, 3 BB(7) / 5.81151604367358E-05/, BB(8) / 2.28802638122969E-05/, 4 BB(9) /-1.35078982929539E-06/, BB(10)/-3.13213946132892E-07/, 5 BB(11)/ 1.86619586786257E-08/, BB(12)/ 3.03991719607226E-09/, 6 BB(13)/-1.76437788946489E-10/, BB(14)/-2.20236421792690E-11/, 7 BB(15)/ 1.22710107703240E-12/, BB(16)/ 1.23680681116783E-13/ C ------------------- DATA CC(1) / 9.76155271128712E-01/, CC(2) / 8.96845854916423E-02/, 1 CC(3) /-3.04656658030696E-02/, CC(4) / 8.50892472922945E-02/, 2 CC(5) /-5.78073683148386E-03/, CC(6) /-5.07182677775691E-03/, 3 CC(7) / 8.38643256650893E-04/, CC(8) /-3.34223415981738E-04/, 4 CC(9) /-2.15746207281216E-05/, CC(10)/ 1.28560650086065E-04/, 5 CC(11)/-1.56456413510232E-05/, CC(12)/-1.52025513597262E-05/, 6 CC(13)/ 4.04001013843204E-06/, CC(14)/-5.95896122752160E-07/, 7 CC(15)/-4.34985305974340E-07/, CC(16)/ 7.13472533530840E-07/, 8 CC(17)/-5.34302186061100E-08/, CC(18)/-1.76003581156610E-07/, 9 CC(19)/ 3.85028855125900E-08/, CC(20)/ 1.92576544441700E-08/, 1 CC(21)/-1.00735358217200E-08/, CC(22)/ 3.36359194377000E-09/, 2 CC(23)/ 1.28049619406000E-09/, CC(24)/-2.42546870827000E-09/, 3 CC(25)/ 1.86917288950000E-10/, CC(26)/ 7.13431298340000E-10/, 4 CC(27)/-1.70673483710000E-10/, CC(28)/-1.14604070350000E-10/, 5 CC(29)/ 5.88004411500000E-11/, CC(30)/-6.78417843000000E-12/, 6 CC(31)/-1.21572380900000E-11/, CC(32)/ 1.26561248700000E-11/, 7 CC(33)/ 4.74814180000000E-13/, CC(34)/-5.32309477000000E-12/, 8 CC(35)/ 9.05903810000000E-13/, CC(36)/ 1.40046450000000E-12/, 9 CC(37)/-5.00968320000000E-13/, CC(38)/-1.80458040000000E-13/ DATA CC(39)/ 1.66162910000000E-13/, CC(40)/-5.02616400000000E-14/, 1 CC(41)/-3.48453600000000E-14/, CC(42)/ 4.60056600000000E-14/, 2 CC(43)/ 5.74000000000000E-16/, CC(44)/-1.95310700000000E-14/, 3 CC(45)/ 3.68837000000000E-15/, CC(46)/ 5.62862000000000E-15/ C ------------------- C ****** AMAX IS A MACHINE DEPENDENT CONSTANT. IT IS ASSUMED THAT C SIN(X) AND COS(X) ARE DEFINED FOR ABS(X) .LE. AMAX, AND C THAT PIO2 - (1 + 1/X)/X = PIO2 FOR X .GT. AMAX. C AMAX = 1.0/SPMPAR(1) C C AX=ABS(X) IF (AX.GT.5.0) GO TO 20 J=N1 BX=0.40*AX-1.0 TX=BX+BX B1=BB(J) B2=0. DO 10 I=1,M1 J=J-1 TEMP=B1 B1=TX*B1-B2+BB(J) 10 B2=TEMP SI=(BX*B1-B2+BB(1))*X RETURN C 20 IF (AX.GT.AMAX) GO TO 50 BX=10./AX-1. TX=BX+BX J=N2 B1=CC(J) B2=0.0 DO 30 I=1,M2 J=J-2 TEMP=B1 B1=TX*B1-B2+CC(J) 30 B2=TEMP AIC=BX*B1-B2+CC(2) C J=N2-1 B1=CC(J) B2=0.0 DO 40 I=1,M2 J=J-2 TEMP=B1 B1=TX*B1-B2+CC(J) 40 B2=TEMP RC=BX*B1-B2+CC(1) C SI=(RC*COS(AX)+AIC*SIN(AX))/AX SI=PIO2-SI IF (X.LT.0.0) SI=-SI RETURN C 50 SI=SIGN(PIO2,X) RETURN END FUNCTION CIN(X) C C WRITTEN BY D.E. AMOS AND S.L. DANIEL, NOVEMBER, 1975. C MODIFIED BY A.H. MORRIS C C REFERENCES C SAND76-0062 C THE SPECIAL FUNCTIONS AND THEIR APPROXIMATIONS, VOL. II, BY C Y.L. LUKE. ACADEMIC PRESS, NEW YORK, 1969. C C ABSTRACT C CIN COMPUTES THE INTEGRAL OF (1-COS(T))/T ON (0,X) BY MEANS C OF CHEBYSHEV EXPANSIONS ON (0,5) AND (5,INFINITY). C C DESCRIPTION OF ARGUMENTS C C INPUT C X - LIMIT OF INTEGRATION, UNRESTRICTED C C OUTPUT C CIN - VALUE OF THE INTEGRAL C C DIMENSION BB(16),CC(46) C ------------------- DATA N1,N2,M1,M2 / 16, 46, 14, 21 / DATA ECON / 5.77215664901533E-01/ C ------------------- DATA BB(1) / 1.82820351064538E-01/, BB(2) /-8.23768704567135E-02/, 1 BB(3) /-1.03468764544958E-02/, BB(4) / 5.05085201960312E-03/, 2 BB(5) / 5.73772812356328E-05/, BB(6) /-1.42717916181096E-04/, 3 BB(7) / 2.89263664732599E-06/, BB(8) / 2.43068098304909E-06/, 4 BB(9) /-7.90337487433443E-08/, BB(10)/-2.80205535437371E-08/, 5 BB(11)/ 1.05488738052065E-09/, BB(12)/ 2.34186901801115E-10/, 6 BB(13)/-9.27762554764014E-12/, BB(14)/-1.48682586858284E-12/, 7 BB(15)/ 5.95210263082868E-14/, BB(16)/ 7.42057835287916E-15/ C ------------------- DATA CC(1) / 9.76155271128712E-01/, CC(2) / 8.96845854916423E-02/, 1 CC(3) /-3.04656658030696E-02/, CC(4) / 8.50892472922945E-02/, 2 CC(5) /-5.78073683148386E-03/, CC(6) /-5.07182677775691E-03/, 3 CC(7) / 8.38643256650893E-04/, CC(8) /-3.34223415981738E-04/, 4 CC(9) /-2.15746207281216E-05/, CC(10)/ 1.28560650086065E-04/, 5 CC(11)/-1.56456413510232E-05/, CC(12)/-1.52025513597262E-05/, 6 CC(13)/ 4.04001013843204E-06/, CC(14)/-5.95896122752160E-07/, 7 CC(15)/-4.34985305974340E-07/, CC(16)/ 7.13472533530840E-07/, 8 CC(17)/-5.34302186061100E-08/, CC(18)/-1.76003581156610E-07/, 9 CC(19)/ 3.85028855125900E-08/, CC(20)/ 1.92576544441700E-08/, 1 CC(21)/-1.00735358217200E-08/, CC(22)/ 3.36359194377000E-09/, 2 CC(23)/ 1.28049619406000E-09/, CC(24)/-2.42546870827000E-09/, 3 CC(25)/ 1.86917288950000E-10/, CC(26)/ 7.13431298340000E-10/, 4 CC(27)/-1.70673483710000E-10/, CC(28)/-1.14604070350000E-10/, 5 CC(29)/ 5.88004411500000E-11/, CC(30)/-6.78417843000000E-12/, 6 CC(31)/-1.21572380900000E-11/, CC(32)/ 1.26561248700000E-11/, 7 CC(33)/ 4.74814180000000E-13/, CC(34)/-5.32309477000000E-12/, 8 CC(35)/ 9.05903810000000E-13/, CC(36)/ 1.40046450000000E-12/, 9 CC(37)/-5.00968320000000E-13/, CC(38)/-1.80458040000000E-13/ DATA CC(39)/ 1.66162910000000E-13/, CC(40)/-5.02616400000000E-14/, 1 CC(41)/-3.48453600000000E-14/, CC(42)/ 4.60056600000000E-14/, 2 CC(43)/ 5.74000000000000E-16/, CC(44)/-1.95310700000000E-14/, 3 CC(45)/ 3.68837000000000E-15/, CC(46)/ 5.62862000000000E-15/ C ------------------- C ****** AMAX IS A MACHINE DEPENDENT CONSTANT. IT IS ASSUMED THAT C SIN(X) AND COS(X) ARE DEFINED FOR ABS(X) .LE. AMAX, AND C THAT ECON + LN(X) - (1 + 1/X)/X = ECON + LN(X) C FOR X .GT. AMAX. C AMAX = 0.1/SPMPAR(1) C C AX = ABS(X) IF (AX.GT.5.0) GO TO 20 J=N1 BX=0.40*AX-1.0 TX=BX+BX B1=BB(J) B2=0. DO 10 I=1,M1 J=J-1 TEMP=B1 B1=TX*B1-B2+BB(J) 10 B2=TEMP CIN=X*X*(BX*B1-B2+BB(1)) RETURN C 20 IF (AX.GT.AMAX) GO TO 50 BX=10./AX-1.0 TX=BX+BX J=N2 B1=CC(J) B2=0.0 DO 30 I=1,M2 J=J-2 TEMP=B1 B1=TX*B1-B2+CC(J) 30 B2=TEMP AIC=BX*B1-B2+CC(2) C J=N2-1 B1=CC(J) B2=0.0 DO 40 I=1,M2 J=J-2 TEMP=B1 B1=TX*B1-B2+CC(J) 40 B2=TEMP RC=BX*B1-B2+CC(1) C CIN=(RC*SIN(AX)-AIC*COS(AX))/AX CIN=(ECON-CIN)+ALOG(AX) RETURN C 50 CIN=ECON+ALOG(AX) RETURN END SUBROUTINE CEXEXI (Z, W) C----------------------------------------------------------------------- C COMPUTATION OF THE EXPONENTIAL EXPONENTIAL INTEGRAL C----------------------------------------------------------------------- COMPLEX Z, W REAL TS(2), SR(2), SM(2), TM(2), QF(2), ZL(2) REAL ED(18), EE(18), DD(19), DE(19), CD(18), CE(18) C------------------------- C EULER = EULER CONSTANT C CONST = (PI*PI)/4 C ZETA2 = THE RIEMANN ZETA FUNCTION EVALUATED AT 2 C------------------------- DATA CONST /2.46740110027234/ DATA EULER /.577215664901533/ DATA ZETA2 /1.64493406684823/ C------------------------- DATA ED(1) /0.00000000000000E+00/, ED(2) /.311105957086528E-01/, * ED(3) /.103661260539112E+00/, ED(4) /.216532335244554E+00/, * ED(5) /.369931427960192E+00/, ED(6) /.566766259990589E+00/, * ED(7) /.814042066324748E+00/, ED(8) /.112384247540813E+01/, * ED(9) /.151400478148512E+01/, ED(10) /.200886795032284E+01/, * ED(11) /.264052411823592E+01/, ED(12) /.345098449933392E+01/, * ED(13) /.449583360763202E+01/, ED(14) /.585058263409822E+01/, * ED(15) /.762273501463380E+01/, ED(16) /.997814501584578E+01/, * ED(17) /.132122064896408E+02/, ED(18) /.180322948376021E+02/ DATA EE(1) /.850156516121093E-02/, EE(2) /.505037465849058E-01/, * EE(3) /.836817368956407E-01/, EE(4) /.107047582417607E+00/, * EE(5) /.120424719029462E+00/, EE(6) /.125096631582229E+00/, * EE(7) /.122314435224685E+00/, EE(8) /.112621417553907E+00/, * EE(9) /.963419407392582E-01/, EE(10) /.747398422757511E-01/, * EE(11) /.508596135953441E-01/, EE(12) /.290822706773628E-01/, * EE(13) /.132201640530101E-01/, EE(14) /.443802939829067E-02/, * EE(15) /.992612478987576E-03/, EE(16) /.126579795112011E-03/, * EE(17) /.702150908253350E-05/, EE(18) /.910281532564632E-07/ C------------------------- DATA DD(1) /0.00000000000000E+00/, DD(2) /.419556678374293E-01/, * DD(3) /.117533661648665E+00/, DD(4) /.228560237455987E+00/, * DD(5) /.375667350161240E+00/, DD(6) /.791594846276672E+00/, * DD(7) /.107546889623058E+01/, DD(8) /.142659208030841E+01/, * DD(9) /.186290554952377E+01/, DD(10) /.240730009509856E+01/, * DD(11) /.308854035607524E+01/, DD(12) /.394277605155259E+01/, * DD(13) /.501593196543981E+01/, DD(14) /.636759180748651E+01/, * DD(15) /.807776193096055E+01/, DD(16) /.102598961138887E+02/, * DD(17) /.130896768422610E+02/, DD(18) /.168832169085916E+02/, * DD(19) /.224083240941713E+02/ DATA DE(1) /-.346911733535892E-03/, DE(2) /-.603787732461745E-02/, * DE(3) /-.152461305949249E-01/, DE(4) /-.210582169827291E-01/, * DE(5) /-.171894208720754E-01/, DE(6) /.314323467033032E-01/, * DE(7) /.750898531566972E-01/, DE(8) /.124689787807260E+00/, * DE(9) /.168579075090035E+00/, DE(10) /.191715080699511E+00/, * DE(11) /.182600794550836E+00/, DE(12) /.142345674307147E+00/, * DE(13) /.874862222419327E-01/, DE(14) /.402175083288425E-01/, * DE(15) /.128575005680180E-01/, DE(16) /.257673782598441E-02/, * DE(17) /.275955003784349E-03/, DE(18) /.119139315517122E-04/, * DE(19) /.107292980199386E-06/ C------------------------- DATA CD(1) /0.00000000000000E+00/, CD(2) /.237286128313683E-01/, * CD(3) /.854113210668760E-01/, CD(4) /.185276627282059E+00/, * CD(5) /.323741526616688E+00/, CD(6) /.503045460381267E+00/, * CD(7) /.728806607587188E+00/, CD(8) /.101122770102872E+01/, * CD(9) /.136598448171249E+01/, CD(10) /.181510139038929E+01/, * CD(11) /.238824701955419E+01/, CD(12) /.312490532008812E+01/, * CD(13) /.407802489894445E+01/, CD(14) /.532033545554865E+01/, * CD(15) /.695624307290579E+01/, CD(16) /.914759902547031E+01/, * CD(17) /.121829074388544E+02/, CD(18) /.167511311969873E+02/ DATA CE(1) /.349517258926827E-01/, CE(2) /.135849105925897E+00/, * CE(3) /.158850581552296E+00/, CE(4) /.153001434535435E+00/, * CE(5) /.134520752856461E+00/, CE(6) /.111913051619671E+00/, * CE(7) /.892008386656190E-01/, CE(8) /.679227205472067E-01/, * CE(9) /.486723197887211E-01/, CE(10) /.320170976532266E-01/, * CE(11) /.187008965021111E-01/, CE(12) /.929708414427865E-02/, * CE(13) /.372604763161087E-02/, CE(14) /.111989537559823E-02/, * CE(15) /.228057496872353E-03/, CE(16) /.269596227781453E-04/, * CE(17) /.141255430224301E-05/, CE(18) /.176352326808806E-07/ C------------------------- X = REAL(Z) Y = AIMAG(Z) R = X*X + Y*Y C IF (R .LE. 1.0) GO TO 100 IF (R .GE. 1296.0) GO TO 10 IF (X .LT. 0.07*Y*Y) GO TO 30 GO TO 40 C----------------------------------------------------------------------- C ASYMPTOTIC EXPANSION C----------------------------------------------------------------------- 10 QF(1) = X/R QF(2) = -Y/R SM(1) = -QF(1) SM(2) = -QF(2) TM(1) = SM(1) TM(2) = SM(2) PM = 1.0 20 TS(1) = TM(1)*QF(1) - TM(2)*QF(2) TS(2) = TM(1)*QF(2) + TM(2)*QF(1) TM(1) = PM*TS(1) TM(2) = PM*TS(2) PM = PM + 1.0 TS(1) = TM(1)/PM TS(2) = TM(2)/PM IF (ABS(SM(1)) + ABS(TS(1)) .NE. ABS(SM(1))) GO TO 21 IF (ABS(SM(2)) + ABS(TS(2)) .EQ. ABS(SM(2))) GO TO 130 21 SM(1) = SM(1) + TS(1) SM(2) = SM(2) + TS(2) IF (PM .LT. 36.0) GO TO 20 GO TO 130 C----------------------------------------------------------------------- C RATIONAL EXPANSION C----------------------------------------------------------------------- 30 SM(1) = 0.0 SM(2) = 0.0 DO 31 I = 1,18 TS(1) = X - CD(I) TS(2) = Y SS = TS(1)*TS(1) + TS(2)*TS(2) TM(1) = -CE(I)*TS(1)/SS TM(2) = CE(I)*TS(2)/SS SM(1) = SM(1) + TM(1) SM(2) = SM(2) + TM(2) 31 CONTINUE GO TO 130 C----------------------------------------------------------------------- C EXPANSION INVOLVING EI AND DI C----------------------------------------------------------------------- 40 ZL(1) = EULER + 0.5*ALOG(R) ZL(2) = ATAN2(-Y, -X) C C SET SM = EXP(Z)*EI(-Z) C SM(1) = 0.0 SM(2) = 0.0 DO 50 I = 1,18 TS(1) = -X - ED(I) TS(2) = -Y SS = TS(1)*TS(1) + TS(2)*TS(2) TM(1) = EE(I)*TS(1)/SS TM(2) = -EE(I)*TS(2)/SS SM(1) = SM(1) + TM(1) SM(2) = SM(2) + TM(2) 50 CONTINUE SR(1) = ZL(1)*SM(1) - ZL(2)*SM(2) SR(2) = ZL(1)*SM(2) + ZL(2)*SM(1) C C SET SM = EXP(Z)*DI(-Z) C SM(1) = 0.0 SM(2) = 0.0 DO 60 I = 1,19 TS(1) = -X - DD(I) TS(2) = -Y SS = TS(1)*TS(1) + TS(2)*TS(2) TM(1) = DE(I)*TS(1)/SS TM(2) = -DE(I)*TS(2)/SS SM(1) = SM(1) + TM(1) SM(2) = SM(2) + TM(2) 60 CONTINUE TS(1) = -(X*SM(1) + Y*SM(2))/R TS(2) = -(X*SM(2) - Y*SM(1))/R C C COMPUTE THE EXPANSION C SR(1) = SR(1) - TS(1) - ZETA2 SR(2) = SR(2) - TS(2) SM(1) = 0.0 SM(2) = 0.0 TM(1) = 1.0 TM(2) = 0.0 PM = 0.0 QM = ZETA2 70 PM = PM + 1.0 QM = QM - 1.0/(PM*PM) TS(1) = TM(1)*X - TM(2)*Y TS(2) = TM(1)*Y + TM(2)*X TM(1) = TS(1)/PM TM(2) = TS(2)/PM TS(1) = QM*TM(1) TS(2) = QM*TM(2) IF (ABS(SM(1)) + ABS(TS(1)) .NE. ABS(SM(1))) GO TO 71 IF (ABS(SM(2)) + ABS(TS(2)) .EQ. ABS(SM(2))) GO TO 80 71 SM(1) = SM(1) - TS(1) SM(2) = SM(2) - TS(2) GO TO 70 80 SM(1) = SR(1) + SM(1) SM(2) = SR(2) + SM(2) C C COMPUTE EXP(-Z)*SM C QM = EXP(-X) QF(1) = QM*COS(-Y) QF(2) = QM*SIN(-Y) TS(1) = QF(1)*SM(1) - QF(2)*SM(2) TS(2) = QF(1)*SM(2) + QF(2)*SM(1) SM(1) = TS(1) SM(2) = TS(2) GO TO 130 C----------------------------------------------------------------------- C SERIES FOR X*X + Y*Y .LE. 1 C----------------------------------------------------------------------- 100 SM(1) = 0.0 SM(2) = 0.0 ZL(1) = EULER + 0.5*ALOG(R) ZL(2) = ATAN2(-Y, -X) SR(1) = CONST + 0.5*(ZL(1)*ZL(1) - ZL(2)*ZL(2)) SR(2) = ZL(1)*ZL(2) TM(1) = 1.0 TM(2) = 0.0 PM = 0.0 QM = 0.0 110 PM = PM + 1.0 QM = QM + 1.0/PM TS(1) = -TM(1)*X + TM(2)*Y TS(2) = -TM(1)*Y - TM(2)*X TM(1) = TS(1)/PM TM(2) = TS(2)/PM R = (ZL(1) - 1.0/PM) - QM TS(1) = (R*TM(1) - ZL(2)*TM(2))/PM TS(2) = (R*TM(2) + ZL(2)*TM(1))/PM IF (ABS(SM(1)) + ABS(TS(1)) .NE. ABS(SM(1))) GO TO 111 IF (ABS(SM(2)) + ABS(TS(2)) .EQ. ABS(SM(2))) GO TO 120 111 SM(1) = SM(1) + TS(1) SM(2) = SM(2) + TS(2) GO TO 110 120 SM(1) = SR(1) + SM(1) SM(2) = SR(2) + SM(2) C----------------------------------------------------------------------- C TERMINATION C----------------------------------------------------------------------- 130 W = CMPLX(SM(1), SM(2)) RETURN END COMPLEX FUNCTION CLI(Z) C ****************************************************************** C COMPUTATION OF THE COMPLEX LOGARITHMIC INTEGRAL C ****************************************************************** COMPLEX Z REAL QB(25), QF(2), DL(2), DS, ZD(2), ZL(2) REAL AZ(2), C, PM, R, SM(2), TM(2), TS(2), SR(2) C --------------------- C C = PI**2/6 C --------------------- DATA C /1.64493406684823/ C --------------------- DATA QB(1) / 2.77777777777778E-2/, QB(2) /-1.00000000000000E-2/, 1 QB(3) /-1.70068027210884E-2/, QB(4) /-1.94444444444444E-2/, 2 QB(5) /-2.06611570247934E-2/, QB(6) /-2.14173006480699E-2/, 3 QB(7) /-2.19488663772311E-2/, QB(8) /-2.23492338111715E-2/, 4 QB(9) /-2.26636891351914E-2/, QB(10)/-2.29178211549926E-2/, 5 QB(11)/-2.31276449354844E-2/, QB(12)/-2.33038680700203E-2/, 6 QB(13)/-2.34539766464373E-2/, QB(14)/-2.35833786876607E-2/, 7 QB(15)/-2.36960832049849E-2/, QB(16)/-2.37951264448373E-2/, 8 QB(17)/-2.38828504258091E-2/, QB(18)/-2.39610907251825E-2/, 9 QB(19)/-2.40313063764460E-2/, QB(20)/-2.40946717197585E-2/, 1 QB(21)/-2.41521426124012E-2/, QB(22)/-2.42045049812210E-2/, 2 QB(23)/-2.42524109782181E-2/, QB(24)/-2.42964062815807E-2/, 3 QB(25)/-2.43369509729144E-2/ C --------------------- AZ(1) = REAL(Z) AZ(2) = AIMAG(Z) R = CPABS(AZ(1),AZ(2)) IF (R .GT. 0.5) GO TO 10 SR(1) = 0.0 SR(2) = 0.0 QF(1) = -AZ(1) QF(2) = -AZ(2) TM(1) = AZ(1) TM(2) = AZ(2) GO TO 30 C 10 IF (R .LT. 3.0) GO TO 20 ZL(1) = ALOG(R) ZL(2) = ATAN2(AZ(2),AZ(1)) SR(1) = C + 0.5*(ZL(1)*ZL(1) - ZL(2)*ZL(2)) SR(2) = ZL(1)*ZL(2) QF(1) = (-AZ(1)/R)/R QF(2) = (AZ(2)/R)/R TM(1) = QF(1) TM(2) = QF(2) GO TO 30 C 20 ZD(1) = 1.0 + AZ(1) ZD(2) = AZ(2) DS = ZD(1)*ZD(1) + ZD(2)*ZD(2) IF (DS .EQ. 0.0) GO TO 100 DL(1) = 0.5*ALOG(DS) DL(2) = ATAN2(ZD(2),ZD(1)) IF (DS .GT. 0.25) GO TO 50 ZL(1) = ALOG(R) ZL(2) = ATAN2(-AZ(2),-AZ(1)) SR(1) = -C + (DL(1)*ZL(1) - DL(2)*ZL(2)) SR(2) = DL(1)*ZL(2) + DL(2)*ZL(1) QF(1) = ZD(1) QF(2) = ZD(2) TM(1) = QF(1) TM(2) = QF(2) C C EVALUATION OF THE TAYLOR SERIES C 30 SR(1) = SR(1) + TM(1) SR(2) = SR(2) + TM(2) SM(1) = 0.0 SM(2) = 0.0 PM = 1.0 40 PM = PM + 1.0 TS(1) = TM(1)*QF(1) - TM(2)*QF(2) TS(2) = TM(1)*QF(2) + TM(2)*QF(1) TM(1) = TS(1) TM(2) = TS(2) TS(1) = TM(1)/(PM*PM) TS(2) = TM(2)/(PM*PM) IF (ABS(SM(1)) + ABS(TS(1)) .NE. ABS(SM(1))) GO TO 41 IF (ABS(SM(2)) + ABS(TS(2)) .EQ. ABS(SM(2))) GO TO 80 41 SM(1) = SM(1) + TS(1) SM(2) = SM(2) + TS(2) GO TO 40 C C EVALUATION OF THE SERIES IN U = -LN(1 + Z) C 50 QF(1) = DL(1)*DL(1) - DL(2)*DL(2) QF(2) = 2.0*DL(1)*DL(2) SR(1) = DL(1) + 0.25*QF(1) SR(2) = DL(2) + 0.25*QF(2) SM(1) = 0.0 SM(2) = 0.0 TM(1) = DL(1) TM(2) = DL(2) DO 61 N = 1,25 TS(1) = QB(N)*(TM(1)*QF(1) - TM(2)*QF(2)) TS(2) = QB(N)*(TM(1)*QF(2) + TM(2)*QF(1)) TM(1) = TS(1) TM(2) = TS(2) IF (ABS(SM(1)) + ABS(TM(1)) .NE. ABS(SM(1))) GO TO 60 IF (ABS(SM(2)) + ABS(TM(2)) .EQ. ABS(SM(2))) GO TO 80 60 SM(1) = SM(1) + TM(1) SM(2) = SM(2) + TM(2) 61 CONTINUE C 80 CLI = CMPLX(SR(1) + SM(1), SR(2) + SM(2)) RETURN C C EVALUATION AT Z = -1 C 100 CLI = CMPLX(-C, 0.0) RETURN END REAL FUNCTION ALI(X) C----------------------------------------------------------------------- C COMPUTATION OF THE REAL DILOGARITHM FUNCTION C----------------------------------------------------------------------- C WRITTEN BY C ALFRED H. MORRIS, JR. C NAVAL SURFACE WEAPONS CENTER C DAHLGREN VIRGINIA C----------------------------------------------------------------------- REAL A(5), B(6), C(10), D(2), E(18), P(4), Q(8), R(7), S(6) DOUBLE PRECISION X0 C-------------------------- C CONST = PI**2/6 C X0 = ZERO OF THE REAL DILOGARITHM FUNCTION C-------------------------- DATA CONST /1.64493406684823/ DATA X0 /-12.5951703698450161286398965D0/ C-------------------------- DATA A(1)/.217590467528373E+01/, A(2)/.165569610692639E+01/, * A(3)/.522944061702389E+00/, A(4)/.626073688152965E-01/, * A(5)/.187280204672313E-02/ DATA B(1)/.242590467528371E+01/, B(2)/.215106116463796E+01/, * B(3)/.853664388896516E+00/, B(4)/.148635712775060E+00/, * B(5)/.936304016023909E-02/, B(6)/.115362459229893E-03/ C-------------------------- DATA C(1)/-.139792925233661E+01/, C(2) /.368504569727477E+00/, * C(3) /.467406917183686E-01/, C(4) /.113795257294490E-01/, * C(5) /.369638462505741E-02/, C(6) /.140888669464352E-02/, * C(7) /.580505641503297E-03/, C(8) /.279065584075104E-03/, * C(9) /.727678355839120E-04/, C(10)/.941452067850052E-04/ DATA D(1)/-.164792925233634E+01/, D(2) /.669375771675355E+00/ C-------------------------- DATA E(1)/-.194565741631859E+00/, E(2)/-.430017756528812E-02/, * E(3)/-.129188263110634E-03/, E(4)/-.344864872694838E-05/, * E(5) /.566899694553089E-09/, E(6) /.126641834906132E-07/, * E(7) /.163966793864421E-08/, E(8) /.164221074630109E-09/, * E(9) /.149644905021032E-10/, E(10)/.130214292886747E-11/, * E(11)/.110415518123737E-12/, E(12)/.921674760163207E-14/, * E(13)/.761646464974859E-15/, E(14)/.625216733700975E-16/, * E(15)/.510910937990370E-17/, E(16)/.416215390793180E-18/, * E(17)/.338357379188308E-19/, E(18)/.274674744366340E-20/ C-------------------------- DATA P(1)/-.124827318209942E+01/, P(2)/-.593706951284264E-01/, * P(3)/ .368603360394688E-01/, P(4)/ .243497524184253E-02/ DATA Q(1)/ .100000000000000E+01/, Q(2)/ .252618047164349E+00/, * Q(3)/ .171618729068655E-01/, Q(4)/ .234444792844727E-03/, * Q(5)/-.174928841869743E-05/, Q(6)/ .347369010951250E-07/, * Q(7)/-.713275908929482E-09/, Q(8)/ .958397514026421E-11/ C-------------------------- DATA R(1)/.265189940015693E+00/, R(2)/.230201018075415E+00/, * R(3)/.315999623504943E-01/, R(4)/.154066621939470E-02/, * R(5)/.286697611038892E-04/, R(6)/.163031291368652E-06/, * R(7)/.838957807732251E-10/ DATA S(1)/.100000000000000E+01/, S(2)/.177195068872258E+00/, * S(3)/.110559275223905E-01/, S(4)/.291916852717175E-03/, * S(5)/.304793254397420E-05/, S(6)/.882114921507386E-08/ C-------------------------- C IF (X .GT. 1.0) GO TO 50 IF (X .GE. 0.0) GO TO 40 IF (X .GE.-0.5) GO TO 30 IF (X .GE.-1.0) GO TO 20 IF (X .GE.-2.0) GO TO 10 C C X .LT. -2 C IF (X .GE. -26.63 .AND. X .LE. -6.97) GO TO 100 T = -1.0/X W = (((((((((((C(10)*T + C(9))*T + C(8))*T + C(7))*T + C(6))*T + * C(5))*T + C(4))*T + C(3))*T + C(2))*T + C(1))*T + * 0.5) + 0.5) / ((D(2)*T + D(1))*T + 1.0) ALI = 0.5*ALOG(-X)**2 - (2.0*CONST + W/X) RETURN C C -2 .LE. X .LT. -1 C 10 T = -(1.0 + X) W = (((((A(5)*T + A(4))*T + A(3))*T + A(2))*T + A(1))*T + 1.0)/ * ((((((B(6)*T + B(5))*T + B(4))*T + B(3))*T + B(2))*T + * B(1))*T + 1.0) ALI = -(CONST + T*W) + ALOG(-X)*ALOG(T) RETURN C C -1 .LE. X .LT. -1/2 C 20 T = 0.5 + (0.5 + X) ALI = -CONST IF (T .EQ. 0.0) RETURN W = (((((((((((C(10)*T + C(9))*T + C(8))*T + C(7))*T + C(6))*T + * C(5))*T + C(4))*T + C(3))*T + C(2))*T + C(1))*T + * 0.5) + 0.5) / ((D(2)*T + D(1))*T + 1.0) ALI = (-CONST + T*W) + ALOG(-X)*ALOG(T) RETURN C C -1/2 .LE. X .LT. 0 C 30 T = -X W = (((((((((((C(10)*T + C(9))*T + C(8))*T + C(7))*T + C(6))*T + * C(5))*T + C(4))*T + C(3))*T + C(2))*T + C(1))*T + * 0.5) + 0.5) / ((D(2)*T + D(1))*T + 1.0) ALI = X*W RETURN C C 0 .LE. X .LE. 1 C 40 W = (((((A(5)*X + A(4))*X + A(3))*X + A(2))*X + A(1))*X + 1.0)/ * ((((((B(6)*X + B(5))*X + B(4))*X + B(3))*X + B(2))*X + * B(1))*X + 1.0) ALI = X*W RETURN C C X .GT. 1 C 50 T = 1.0/X W = (((((A(5)*T + A(4))*T + A(3))*T + A(2))*T + A(1))*T + 1.0)/ * ((((((B(6)*T + B(5))*T + B(4))*T + B(3))*T + B(2))*T + * B(1))*T + 1.0) ALI = (CONST - W/X) + 0.5*ALOG(X)**2 RETURN C C----------------------------------------------------------------------- C EVALUATION FOR -26.63 .LE. X .LE. -6.97 C----------------------------------------------------------------------- C 100 IF (X .LE. -14.0) GO TO 120 IF (X .LE. -11.1) GO TO 110 C C -11.1 .LT. X .LE. -6.97 C T = -(X + 7.0) ALI = (((P(4)*T + P(3))*T + P(2))*T + P(1)) / (((((((Q(8)*T + * Q(7))*T + Q(6))*T + Q(5))*T + Q(4))*T + Q(3))*T + * Q(2))*T + Q(1)) RETURN C C -14 .LT. X .LE. -11.1 C 110 T = DBLE(X) - X0 W = E(14) DO 111 L = 1,13 I = 14 - L 111 W = W*T + E(I) ALI = T*W RETURN C C -26.63 .LE. X .LE. -14 C 120 T = -(X + 14.0) ALI = ((((((R(7)*T + R(6))*T + R(5))*T + R(4))*T + R(3))*T + * R(2))*T + R(1)) / (((((S(6)*T + S(5))*T + * S(4))*T + S(3))*T + S(2))*T + S(1)) RETURN END SUBROUTINE CGAMMA (MO, Z, W) C----------------------------------------------------------------------- C C EVALUATION OF THE COMPLEX GAMMA AND LOGGAMMA FUNCTIONS C C --------------- C C MO IS AN INTEGER, Z A COMPLEX ARGUMENT, AND W A COMPLEX VARIABLE. C C W = GAMMA(Z) IF MO = 0 C W = LN(GAMMA(Z)) OTHERWISE C C----------------------------------------------------------------------- COMPLEX Z, W COMPLEX ETA, ETA2, SUM REAL C0(12) C--------------------------- C ALPI = LOG(PI) C HL2P = 0.5 * LOG(2*PI) C--------------------------- DATA PI /3.14159265358979/ DATA PI2 /6.28318530717959/ DATA ALPI/1.14472988584940/ DATA HL2P/.918938533204673/ C--------------------------- DATA C0(1) /.833333333333333E-01/, C0(2) /-.277777777777778E-02/, * C0(3) /.793650793650794E-03/, C0(4) /-.595238095238095E-03/, * C0(5) /.841750841750842E-03/, C0(6) /-.191752691752692E-02/, * C0(7) /.641025641025641E-02/, C0(8) /-.295506535947712E-01/, * C0(9) /.179644372368831E+00/, C0(10)/-.139243221690590E+01/, * C0(11)/.134028640441684E+02/, C0(12)/-.156848284626002E+03/ C--------------------------- C C ****** MAX AND EPS ARE MACHINE DEPENDENT CONSTANTS. C MAX IS THE LARGEST POSITIVE INTEGER THAT MAY C BE USED, AND EPS IS THE SMALLEST REAL NUMBER C SUCH THAT 1.0 + EPS .GT. 1.0. C MAX = IPMPAR(3) EPS = SPMPAR(1) C C--------------------------- X = REAL(Z) Y = AIMAG(Z) IF (X .GE. 0.0) GO TO 50 C----------------------------------------------------------------------- C CASE WHEN THE REAL PART OF Z IS NEGATIVE C----------------------------------------------------------------------- Y = ABS(Y) T = -PI*Y ET = EXP(T) E2T = ET*ET C C SET A1 = (1 + E2T)/2 AND A2 = (1 - E2T)/2 C A1 = 0.5*(1.0 + E2T) T2 = T + T IF (T2 .LT. -0.15) GO TO 10 A2 = -0.5*REXP(T2) GO TO 20 10 A2 = 0.5*(0.5 + (0.5 - E2T)) C C COMPUTE SIN(PI*X) AND COS(PI*X) C 20 IF (ABS(X) .GE. AMIN1(FLOAT(MAX), 1.0/EPS)) GO TO 200 K = ABS(X) U = X + K K = MOD(K,2) IF (U .GT. -0.5) GO TO 21 U = 0.5 + (0.5 + U) K = K + 1 21 U = PI*U SN = SIN(U) CN = COS(U) IF (K .NE. 1) GO TO 30 SN = -SN CN = -CN C C SET H1 + H2*I TO PI/SIN(PI*Z) OR LOG(PI/SIN(PI*Z)) C 30 A1 = SN*A1 A2 = CN*A2 A = A1*A1 + A2*A2 IF (A .EQ. 0.0) GO TO 200 IF (MO .NE. 0) GO TO 40 C H1 = A1/A H2 = -A2/A C = PI*ET H1 = C*H1 H2 = C*H2 GO TO 41 C 40 H1 = (ALPI + T) - 0.5*ALOG(A) H2 = -ATAN2(A2,A1) 41 IF (AIMAG(Z) .LT. 0.0) GO TO 42 X = 1.0 - X Y = -Y GO TO 50 42 H2 = -H2 X = 1.0 - X C----------------------------------------------------------------------- C CASE WHEN THE REAL PART OF Z IS NONNEGATIVE C----------------------------------------------------------------------- 50 W1 = 0.0 W2 = 0.0 N = 0 T = X Y2 = Y*Y A = T*T + Y2 CUT = 36.0 IF (EPS .GT. 1.E-8) CUT = 16.0 IF (A .GE. CUT) GO TO 80 IF (A .EQ. 0.0) GO TO 200 51 N = N + 1 T = T + 1.0 A = T*T + Y2 IF (A .LT. CUT) GO TO 51 C C LET S1 + S2*I BE THE PRODUCT OF THE TERMS (Z+J)/(Z+N) C U1 = (X*T + Y2)/A U2 = Y/A S1 = U1 S2 = N*U2 IF (N .LT. 2) GO TO 70 U = T/A NM1 = N - 1 DO 60 J = 1,NM1 V1 = U1 + J*U V2 = (N - J)*U2 C = S1*V1 - S2*V2 D = S1*V2 + S2*V1 S1 = C S2 = D 60 CONTINUE C C SET W1 + W2*I = LOG(S1 + S2*I) WHEN MO IS NONZERO C 70 S = S1*S1 + S2*S2 IF (MO .EQ. 0) GO TO 80 W1 = 0.5 * ALOG(S) W2 = ATAN2(S2,S1) C C SET V1 + V2*I = (Z - 0.5) * LOG(Z + N) - Z C 80 T1 = 0.5 * ALOG(A) - 1.0 T2 = ATAN2(Y,T) U = X - 0.5 V1 = (U*T1 - 0.5) - Y*T2 V2 = U*T2 + Y*T1 C C LET A1 + A2*I BE THE ASYMPTOTIC SUM C ETA = CMPLX(T/A,-Y/A) ETA2 = ETA*ETA M = 12 IF (A .GE. 289.0) M = 6 IF (EPS .GT. 1.E-8) M = M/2 SUM = CMPLX(C0(M),0.0) L = M DO 90 J = 2,M L = L - 1 SUM = CMPLX(C0(L),0.0) + SUM*ETA2 90 CONTINUE SUM = SUM*ETA A1 = REAL(SUM) A2 = AIMAG(SUM) C----------------------------------------------------------------------- C GATHERING TOGETHER THE RESULTS C----------------------------------------------------------------------- W1 = (((A1 + HL2P) - W1) + V1) - N W2 = (A2 - W2) + V2 IF (REAL(Z) .LT. 0.0) GO TO 120 IF (MO .NE. 0) GO TO 110 C C CASE WHEN THE REAL PART OF Z IS NONNEGATIVE AND MO = 0 C A = EXP(W1) W1 = A * COS(W2) W2 = A * SIN(W2) IF (N .EQ. 0) GO TO 140 C = (S1*W1 + S2*W2)/S D = (S1*W2 - S2*W1)/S W1 = C W2 = D GO TO 140 C C CASE WHEN THE REAL PART OF Z IS NONNEGATIVE AND MO IS NONZERO. C THE ANGLE W2 IS REDUCED TO THE INTERVAL -PI .LT. W2 .LE. PI. C 110 IF (W2 .GT. PI) GO TO 111 K = 0.5 - W2/PI2 W2 = W2 + PI2*K GO TO 140 111 K = W2/PI2 - 0.5 W2 = W2 - PI2*FLOAT(K + 1) IF (W2 .LE. -PI) W2 = PI GO TO 140 C C CASE WHEN THE REAL PART OF Z IS NEGATIVE AND MO IS NONZERO C 120 IF (MO .EQ. 0) GO TO 130 W1 = H1 - W1 W2 = H2 - W2 GO TO 110 C C CASE WHEN THE REAL PART OF Z IS NEGATIVE AND MO = 0 C 130 A = EXP(-W1) T1 = A * COS(-W2) T2 = A * SIN(-W2) W1 = H1*T1 - H2*T2 W2 = H1*T2 + H2*T1 IF (N .EQ. 0) GO TO 140 C = W1*S1 - W2*S2 D = W1*S2 + W2*S1 W1 = C W2 = D C C TERMINATION C 140 W = CMPLX(W1,W2) RETURN C----------------------------------------------------------------------- C THE REQUESTED VALUE CANNOT BE COMPUTED C----------------------------------------------------------------------- 200 W = (0.0, 0.0) RETURN END COMPLEX FUNCTION CGAM0 (Z) C----------------------------------------------------------------------- C EVALUATION OF 1/GAMMA(1 + Z) FOR ABS(Z) .LT. 1.0 C----------------------------------------------------------------------- COMPLEX Z, W REAL A(25) C----------------------- DATA A(1) / .577215664901533E+00/, A(2) /-.655878071520254E+00/, * A(3) /-.420026350340952E-01/, A(4) / .166538611382291E+00/, * A(5) /-.421977345555443E-01/, A(6) /-.962197152787697E-02/, * A(7) / .721894324666310E-02/, A(8) /-.116516759185907E-02/, * A(9) /-.215241674114951E-03/, A(10) / .128050282388116E-03/, * A(11) /-.201348547807882E-04/, A(12) /-.125049348214267E-05/, * A(13) / .113302723198170E-05/, A(14) /-.205633841697761E-06/, * A(15) / .611609510448142E-08/, A(16) / .500200764446922E-08/, * A(17) /-.118127457048702E-08/, A(18) / .104342671169110E-09/, * A(19) / .778226343990507E-11/, A(20) /-.369680561864221E-11/ DATA A(21) / .510037028745448E-12/, A(22) /-.205832605356651E-13/, * A(23) /-.534812253942302E-14/, A(24) / .122677862823826E-14/, * A(25) /-.118125930169746E-15/ C----------------------- N = 25 X = REAL(Z) Y = AIMAG(Z) IF (X*X + Y*Y .LE. 0.04) N = 14 C K = N W = A(N) DO 10 I = 2,N K = K - 1 W = A(K) + Z*W 10 CONTINUE CGAM0 = 1.0 + Z*W RETURN END REAL FUNCTION GAMMA(A) C----------------------------------------------------------------------- C C EVALUATION OF THE GAMMA FUNCTION FOR REAL ARGUMENTS C C ----------- C C GAMMA(A) IS ASSIGNED THE VALUE 0 WHEN THE GAMMA FUNCTION CANNOT C BE COMPUTED. C C----------------------------------------------------------------------- C WRITTEN BY ALFRED H. MORRIS, JR. C NAVAL SURFACE WEAPONS CENTER C DAHLGREN, VIRGINIA C----------------------------------------------------------------------- REAL P(7), Q(7) DOUBLE PRECISION D, G, Z, LNX, GLOG C-------------------------- C D = 0.5*(LN(2*PI) - 1) C-------------------------- DATA PI /3.1415926535898/ DATA D /.41893853320467274178D0/ C-------------------------- DATA P(1)/ .539637273585445E-03/, P(2)/ .261939260042690E-02/, 1 P(3)/ .204493667594920E-01/, P(4)/ .730981088720487E-01/, 2 P(5)/ .279648642639792E+00/, P(6)/ .553413866010467E+00/, 3 P(7)/ 1.0/ DATA Q(1)/-.832979206704073E-03/, Q(2)/ .470059485860584E-02/, 1 Q(3)/ .225211131035340E-01/, Q(4)/-.170458969313360E+00/, 2 Q(5)/-.567902761974940E-01/, Q(6)/ .113062953091122E+01/, 3 Q(7)/ 1.0/ C-------------------------- DATA R1/.820756370353826E-03/, R2/-.595156336428591E-03/, 1 R3/.793650663183693E-03/, R4/-.277777777770481E-02/, 2 R5/.833333333333333E-01/ C-------------------------- GAMMA = 0.0 X = A IF (ABS(A) .GE. 15.0) GO TO 60 C----------------------------------------------------------------------- C EVALUATION OF GAMMA(A) FOR ABS(A) .LT. 15 C----------------------------------------------------------------------- T = 1.0 M = INT(A) - 1 C C LET T BE THE PRODUCT OF A-J WHEN A .GE. 2 C IF (M) 20,12,10 10 DO 11 J = 1,M X = X - 1.0 11 T = X*T 12 X = X - 1.0 GO TO 40 C C LET T BE THE PRODUCT OF A+J WHEN A .LT. 1 C 20 T = A IF (A .GT. 0.0) GO TO 30 M = - M - 1 IF (M .EQ. 0) GO TO 22 DO 21 J = 1,M X = X + 1.0 21 T = X*T 22 X = (X + 0.5) + 0.5 T = X*T IF (T .EQ. 0.0) RETURN C 30 CONTINUE C C THE FOLLOWING CODE CHECKS IF 1/T CAN OVERFLOW. THIS C CODE MAY BE OMITTED IF DESIRED. C IF (ABS(T) .GE. 1.E-30) GO TO 40 IF (ABS(T)*SPMPAR(3) .LE. 1.0001) RETURN GAMMA = 1.0/T RETURN C C COMPUTE GAMMA(1 + X) FOR 0 .LE. X .LT. 1 C 40 TOP = P(1) BOT = Q(1) DO 41 I = 2,7 TOP = P(I) + X*TOP 41 BOT = Q(I) + X*BOT GAMMA = TOP/BOT C C TERMINATION C IF (A .LT. 1.0) GO TO 50 GAMMA = GAMMA*T RETURN 50 GAMMA = GAMMA/T RETURN C----------------------------------------------------------------------- C EVALUATION OF GAMMA(A) FOR ABS(A) .GE. 15 C----------------------------------------------------------------------- 60 IF (ABS(A) .GE. 1.E3) RETURN IF (A .GT. 0.0) GO TO 70 X = -A N = X T = X - N IF (T .GT. 0.9) T = 1.0 - T S = SIN(PI*T)/PI IF (MOD(N,2) .EQ. 0) S = -S IF (S .EQ. 0.0) RETURN C C COMPUTE THE MODIFIED ASYMPTOTIC SUM C 70 T = 1.0/(X*X) G = ((((R1*T + R2)*T + R3)*T + R4)*T + R5)/X C C ONE MAY REPLACE THE NEXT STATEMENT WITH LNX = ALOG(X) C BUT LESS ACCURACY WILL NORMALLY BE OBTAINED. C LNX = GLOG(X) C C FINAL ASSEMBLY C Z = X G = (D + G) + (Z - 0.5D0)*(LNX - 1.D0) W = G T = G - DBLE(W) IF (W .GT. 0.99999*EXPARG(0)) RETURN GAMMA = EXP(W)*(1.0 + T) IF (A .LT. 0.0) GAMMA = (1.0/(GAMMA*S))/X RETURN END DOUBLE PRECISION FUNCTION GLOG(X) C ------------------- C EVALUATION OF LN(X) FOR X .GE. 15 C ------------------- REAL X DOUBLE PRECISION Z, W(163) C ------------------- DATA C1/.286228750476730/, C2/.399999628131494/, 1 C3/.666666666752663/ C ------------------- C W(J) = LN(J + 14) FOR EACH J C ------------------- DATA W(1) /.270805020110221007D+01/, 1 W(2) /.277258872223978124D+01/, W(3) /.283321334405621608D+01/, 2 W(4) /.289037175789616469D+01/, W(5) /.294443897916644046D+01/, 3 W(6) /.299573227355399099D+01/, W(7) /.304452243772342300D+01/, 4 W(8) /.309104245335831585D+01/, W(9) /.313549421592914969D+01/, 5 W(10)/.317805383034794562D+01/, W(11)/.321887582486820075D+01/, 6 W(12)/.325809653802148205D+01/, W(13)/.329583686600432907D+01/, 7 W(14)/.333220451017520392D+01/, W(15)/.336729582998647403D+01/, 8 W(16)/.340119738166215538D+01/, W(17)/.343398720448514625D+01/, 9 W(18)/.346573590279972655D+01/, W(19)/.349650756146648024D+01/, 1 W(20)/.352636052461616139D+01/, W(21)/.355534806148941368D+01/, 2 W(22)/.358351893845611000D+01/, W(23)/.361091791264422444D+01/, 3 W(24)/.363758615972638577D+01/, W(25)/.366356164612964643D+01/, 4 W(26)/.368887945411393630D+01/, W(27)/.371357206670430780D+01/, 5 W(28)/.373766961828336831D+01/, W(29)/.376120011569356242D+01/, 6 W(30)/.378418963391826116D+01/ DATA W(31)/.380666248977031976D+01/, 1 W(32)/.382864139648909500D+01/, W(33)/.385014760171005859D+01/, 2 W(34)/.387120101090789093D+01/, W(35)/.389182029811062661D+01/, 3 W(36)/.391202300542814606D+01/, W(37)/.393182563272432577D+01/, 4 W(38)/.395124371858142735D+01/, W(39)/.397029191355212183D+01/, 5 W(40)/.398898404656427438D+01/, W(41)/.400733318523247092D+01/, 6 W(42)/.402535169073514923D+01/, W(43)/.404305126783455015D+01/, 7 W(44)/.406044301054641934D+01/, W(45)/.407753744390571945D+01/, 8 W(46)/.409434456222210068D+01/, W(47)/.411087386417331125D+01/, 9 W(48)/.412713438504509156D+01/, W(49)/.414313472639153269D+01/, 1 W(50)/.415888308335967186D+01/, W(51)/.417438726989563711D+01/, 2 W(52)/.418965474202642554D+01/, W(53)/.420469261939096606D+01/, 3 W(54)/.421950770517610670D+01/, W(55)/.423410650459725938D+01/, 4 W(56)/.424849524204935899D+01/, W(57)/.426267987704131542D+01/, 5 W(58)/.427666611901605531D+01/, W(59)/.429045944114839113D+01/, 6 W(60)/.430406509320416975D+01/ DATA W(61)/.431748811353631044D+01/, 1 W(62)/.433073334028633108D+01/, W(63)/.434380542185368385D+01/, 2 W(64)/.435670882668959174D+01/, W(65)/.436944785246702149D+01/, 3 W(66)/.438202663467388161D+01/, W(67)/.439444915467243877D+01/, 4 W(68)/.440671924726425311D+01/, W(69)/.441884060779659792D+01/, 5 W(70)/.443081679884331362D+01/, W(71)/.444265125649031645D+01/, 6 W(72)/.445434729625350773D+01/, W(73)/.446590811865458372D+01/, 7 W(74)/.447733681447820647D+01/, W(75)/.448863636973213984D+01/, 8 W(76)/.449980967033026507D+01/, W(77)/.451085950651685004D+01/, 9 W(78)/.452178857704904031D+01/, W(79)/.453259949315325594D+01/, 1 W(80)/.454329478227000390D+01/, W(81)/.455387689160054083D+01/, 2 W(82)/.456434819146783624D+01/, W(83)/.457471097850338282D+01/, 3 W(84)/.458496747867057192D+01/, W(85)/.459511985013458993D+01/, 4 W(86)/.460517018598809137D+01/, W(87)/.461512051684125945D+01/, 5 W(88)/.462497281328427108D+01/, W(89)/.463472898822963577D+01/, 6 W(90)/.464439089914137266D+01/ DATA W(91) /.465396035015752337D+01/, 1 W(92) /.466343909411206714D+01/, W(93) /.467282883446190617D+01/, 2 W(94) /.468213122712421969D+01/, W(95) /.469134788222914370D+01/, 3 W(96) /.470048036579241623D+01/, W(97) /.470953020131233414D+01/, 4 W(98) /.471849887129509454D+01/, W(99) /.472738781871234057D+01/, 5 W(100)/.473619844839449546D+01/, W(101)/.474493212836325007D+01/, 6 W(102)/.475359019110636465D+01/, W(103)/.476217393479775612D+01/, 7 W(104)/.477068462446566476D+01/, W(105)/.477912349311152939D+01/, 8 W(106)/.478749174278204599D+01/, W(107)/.479579054559674109D+01/, 9 W(108)/.480402104473325656D+01/, W(109)/.481218435537241750D+01/, 1 W(110)/.482028156560503686D+01/, W(111)/.482831373730230112D+01/, 2 W(112)/.483628190695147800D+01/, W(113)/.484418708645859127D+01/, 3 W(114)/.485203026391961717D+01/, W(115)/.485981240436167211D+01/, 4 W(116)/.486753445045558242D+01/, W(117)/.487519732320115154D+01/, 5 W(118)/.488280192258637085D+01/, W(119)/.489034912822175377D+01/, 6 W(120)/.489783979995091137D+01/ DATA W(121)/.490527477843842945D+01/, 1 W(122)/.491265488573605201D+01/, W(123)/.491998092582812492D+01/, 2 W(124)/.492725368515720469D+01/, W(125)/.493447393313069176D+01/, 3 W(126)/.494164242260930430D+01/, W(127)/.494875989037816828D+01/, 4 W(128)/.495582705760126073D+01/, W(129)/.496284463025990728D+01/, 5 W(130)/.496981329957600062D+01/, W(131)/.497673374242057440D+01/, 6 W(132)/.498360662170833644D+01/, W(133)/.499043258677873630D+01/, 7 W(134)/.499721227376411506D+01/, W(135)/.500394630594545914D+01/, 8 W(136)/.501063529409625575D+01/, W(137)/.501727983681492433D+01/, 9 W(138)/.502388052084627639D+01/, W(139)/.503043792139243546D+01/, 1 W(140)/.503695260241362916D+01/, W(141)/.504342511691924662D+01/, 2 W(142)/.504985600724953705D+01/, W(143)/.505624580534830806D+01/, 3 W(144)/.506259503302696680D+01/, W(145)/.506890420222023153D+01/, 4 W(146)/.507517381523382692D+01/, W(147)/.508140436498446300D+01/, 5 W(148)/.508759633523238407D+01/, W(149)/.509375020080676233D+01/, 6 W(150)/.509986642782419842D+01/ DATA W(151)/.510594547390058061D+01/, 1 W(152)/.511198778835654323D+01/, W(153)/.511799381241675511D+01/, 2 W(154)/.512396397940325892D+01/, W(155)/.512989871492307347D+01/, 3 W(156)/.513579843705026176D+01/, W(157)/.514166355650265984D+01/, 4 W(158)/.514749447681345304D+01/, W(159)/.515329159449777895D+01/, 5 W(160)/.515905529921452903D+01/, W(161)/.516478597392351405D+01/, 6 W(162)/.517048399503815178D+01/, W(163)/.517614973257382914D+01/ C IF (X .GE. 178.0) GO TO 10 N = X T = (X - N)/(X + N) T2 = T*T Z = (((C1*T2 + C2)*T2 + C3)*T2 + 2.0)*T GLOG = W(N - 14) + Z RETURN C 10 GLOG = ALOG(X) RETURN END REAL FUNCTION GAM1(A) C----------------------------------------------------------------------- C COMPUTATION OF 1/GAMMA(A+1) - 1 FOR -0.5 .LE. A .LE. 1.5 C----------------------------------------------------------------------- REAL P(7), Q(5), R(9) C------------------------ DATA P(1)/ .577215664901533E+00/, P(2)/-.409078193005776E+00/, * P(3)/-.230975380857675E+00/, P(4)/ .597275330452234E-01/, * P(5)/ .766968181649490E-02/, P(6)/-.514889771323592E-02/, * P(7)/ .589597428611429E-03/ C------------------------ DATA Q(1)/ .100000000000000E+01/, Q(2)/ .427569613095214E+00/, * Q(3)/ .158451672430138E+00/, Q(4)/ .261132021441447E-01/, * Q(5)/ .423244297896961E-02/ C------------------------ DATA R(1)/-.422784335098468E+00/, R(2)/-.771330383816272E+00/, * R(3)/-.244757765222226E+00/, R(4)/ .118378989872749E+00/, * R(5)/ .930357293360349E-03/, R(6)/-.118290993445146E-01/, * R(7)/ .223047661158249E-02/, R(8)/ .266505979058923E-03/, * R(9)/-.132674909766242E-03/ C------------------------ DATA S1 / .273076135303957E+00/, S2 / .559398236957378E-01/ C------------------------ T = A D = A - 0.5 IF (D .GT. 0.0) T = D - 0.5 IF (T) 30,10,20 C 10 GAM1 = 0.0 RETURN C 20 TOP = (((((P(7)*T + P(6))*T + P(5))*T + P(4))*T + P(3))*T * + P(2))*T + P(1) BOT = (((Q(5)*T + Q(4))*T + Q(3))*T + Q(2))*T + 1.0 W = TOP/BOT IF (D .GT. 0.0) GO TO 21 GAM1 = A*W RETURN 21 GAM1 = (T/A)*((W - 0.5) - 0.5) RETURN C 30 TOP = (((((((R(9)*T + R(8))*T + R(7))*T + R(6))*T + R(5))*T * + R(4))*T + R(3))*T + R(2))*T + R(1) BOT = (S2*T + S1)*T + 1.0 W = TOP/BOT IF (D .GT. 0.0) GO TO 31 GAM1 = A*((W + 0.5) + 0.5) RETURN 31 GAM1 = T*W/A RETURN END REAL FUNCTION GAMLN (A) C----------------------------------------------------------------------- C EVALUATION OF LN(GAMMA(A)) FOR POSITIVE A C----------------------------------------------------------------------- C WRITTEN BY ALFRED H. MORRIS C NAVAL SURFACE WARFARE CENTER C DAHLGREN, VIRGINIA C-------------------------- C D = 0.5*(LN(2*PI) - 1) C-------------------------- DATA D/.418938533204673/ C-------------------------- DATA C0/.833333333333333E-01/, C1/-.277777777760991E-02/, * C2/.793650666825390E-03/, C3/-.595202931351870E-03/, * C4/.837308034031215E-03/, C5/-.165322962780713E-02/ C----------------------------------------------------------------------- IF (A .GT. 0.8) GO TO 10 GAMLN = GAMLN1(A) - ALOG(A) RETURN 10 IF (A .GT. 2.25) GO TO 20 T = (A - 0.5) - 0.5 GAMLN = GAMLN1(T) RETURN C 20 IF (A .GE. 10.0) GO TO 30 N = A - 1.25 T = A W = 1.0 DO 21 I = 1,N T = T - 1.0 21 W = T*W GAMLN = GAMLN1(T - 1.0) + ALOG(W) RETURN C 30 T = (1.0/A)**2 W = (((((C5*T + C4)*T + C3)*T + C2)*T + C1)*T + C0)/A GAMLN = (D + W) + (A - 0.5)*(ALOG(A) - 1.0) END REAL FUNCTION GAMLN1 (A) C----------------------------------------------------------------------- C EVALUATION OF LN(GAMMA(1 + A)) FOR -0.2 .LE. A .LE. 1.25 C----------------------------------------------------------------------- DATA P0/ .577215664901533E+00/, P1/ .844203922187225E+00/, * P2/-.168860593646662E+00/, P3/-.780427615533591E+00/, * P4/-.402055799310489E+00/, P5/-.673562214325671E-01/, * P6/-.271935708322958E-02/ DATA Q1/ .288743195473681E+01/, Q2/ .312755088914843E+01/, * Q3/ .156875193295039E+01/, Q4/ .361951990101499E+00/, * Q5/ .325038868253937E-01/, Q6/ .667465618796164E-03/ C---------------------- DATA R0/.422784335098467E+00/, R1/.848044614534529E+00/, * R2/.565221050691933E+00/, R3/.156513060486551E+00/, * R4/.170502484022650E-01/, R5/.497958207639485E-03/ DATA S1/.124313399877507E+01/, S2/.548042109832463E+00/, * S3/.101552187439830E+00/, S4/.713309612391000E-02/, * S5/.116165475989616E-03/ C---------------------- IF (A .GE. 0.6) GO TO 10 W = ((((((P6*A + P5)*A + P4)*A + P3)*A + P2)*A + P1)*A + P0)/ * ((((((Q6*A + Q5)*A + Q4)*A + Q3)*A + Q2)*A + Q1)*A + 1.0) GAMLN1 = -A*W RETURN C 10 X = (A - 0.5) - 0.5 W = (((((R5*X + R4)*X + R3)*X + R2)*X + R1)*X + R0)/ * (((((S5*X + S4)*X + S3)*X + S2)*X + S1)*X + 1.0) GAMLN1 = X*W RETURN END SUBROUTINE DCGAMA (MO, Z, W) C----------------------------------------------------------------------- C C EVALUATION OF THE COMPLEX GAMMA AND LOGGAMMA FUNCTIONS C C --------------- C C MO IS AN INTEGER. Z AND W ARE INTERPRETED AS DOUBLE PRECISION C COMPLEX NUMBERS. IT IS ASSUMED THAT Z(1) AND Z(2) ARE THE REAL C AND IMAGINARY PARTS OF THE COMPLEX NUMBER Z, AND THAT W(1) AND C W(2) ARE THE REAL AND IMAGINARY PARTS OF W. C C W = GAMMA(Z) IF MO = 0 C W = LN(GAMMA(Z)) OTHERWISE C C----------------------------------------------------------------------- DOUBLE PRECISION Z(2), W(2) DOUBLE PRECISION C0(30), DLPI, HL2P, PI, PI2 DOUBLE PRECISION A, A1, A2, C, CN, CUT, D, EPS, ET, E2T, H1, * H2, Q1, Q2, S, SN, S1, S2, T, T1, T2, U, U1, * U2, V1, V2, W1, W2, X, Y, Y2 DOUBLE PRECISION DPMPAR, DREXP C--------------------------- C DLPI = LOG(PI) C HL2P = 0.5 * LOG(2*PI) C--------------------------- DATA PI /3.141592653589793238462643383279502884197D0/ DATA PI2 /6.283185307179586476925286766559005768394D0/ DATA DLPI /1.144729885849400174143427351353058711647D0/ DATA HL2P /.9189385332046727417803297364056176398614D0/ C--------------------------- DATA C0(1) / .8333333333333333333333333333333333333333D-01/, * C0(2) /-.2777777777777777777777777777777777777778D-02/, * C0(3) / .7936507936507936507936507936507936507937D-03/, * C0(4) /-.5952380952380952380952380952380952380952D-03/, * C0(5) / .8417508417508417508417508417508417508418D-03/, * C0(6) /-.1917526917526917526917526917526917526918D-02/, * C0(7) / .6410256410256410256410256410256410256410D-02/, * C0(8) /-.2955065359477124183006535947712418300654D-01/, * C0(9) / .1796443723688305731649384900158893966944D+00/, * C0(10) /-.1392432216905901116427432216905901116427D+01/ DATA C0(11) / .1340286404416839199447895100069013112491D+02/, * C0(12) /-.1568482846260020173063651324520889738281D+03/, * C0(13) / .2193103333333333333333333333333333333333D+04/, * C0(14) /-.3610877125372498935717326521924223073648D+05/, * C0(15) / .6914722688513130671083952507756734675533D+06/, * C0(16) /-.1523822153940741619228336495888678051866D+08/, * C0(17) / .3829007513914141414141414141414141414141D+09/, * C0(18) /-.1088226603578439108901514916552510537473D+11/, * C0(19) / .3473202837650022522522522522522522522523D+12/, * C0(20) /-.1236960214226927445425171034927132488108D+14/ DATA C0(21) / .4887880647930793350758151625180229021085D+15/, * C0(22) /-.2132033396091937389697505898213683855747D+17/, * C0(23) / .1021775296525700077565287628053585500394D+19/, * C0(24) /-.5357547217330020361082770919196920448485D+20/, * C0(25) / .3061578263704883415043151051329622758194D+22/, * C0(26) /-.1899991742639920405029371429306942902947D+24/, * C0(27) / .1276337403382883414923495137769782597654D+26/, * C0(28) /-.9252847176120416307230242348347622779519D+27/, * C0(29) / .7218822595185610297836050187301637922490D+29/, * C0(30) /-.6045183405995856967743148238754547286066D+31/ C--------------------------- C C ****** MAX AND EPS ARE MACHINE DEPENDENT CONSTANTS. C MAX IS THE LARGEST POSITIVE INTEGER THAT MAY C BE USED, AND EPS IS THE SMALLEST NUMBER SUCH C THAT 1.D0 + EPS .GT. 1.D0. C MAX = IPMPAR(3) EPS = DPMPAR(1) C C--------------------------- X = Z(1) Y = Z(2) IF (X .GE. 0.D0) GO TO 50 C----------------------------------------------------------------------- C CASE WHEN THE REAL PART OF Z IS NEGATIVE C----------------------------------------------------------------------- Y = DABS(Y) T = -PI*Y ET = DEXP(T) E2T = ET*ET C C SET A1 = (1 + E2T)/2 AND A2 = (1 - E2T)/2 C A1 = 0.5D0*(1.D0 + E2T) T2 = T + T IF (T2 .LT. -0.15D0) GO TO 10 A2 = -0.5D0*DREXP(T2) GO TO 20 10 A2 = 0.5D0*(0.5D0 + (0.5D0 - E2T)) C C COMPUTE SIN(PI*X) AND COS(PI*X) C 20 U = MAX IF (DABS(X) .GE. DMIN1(U, 1.D0/EPS)) GO TO 200 K = DABS(X) U = X + K K = MOD(K,2) IF (U .GT. -0.5D0) GO TO 21 U = 0.5D0 + (0.5D0 + U) K = K + 1 21 U = PI*U SN = DSIN(U) CN = DCOS(U) IF (K .NE. 1) GO TO 30 SN = -SN CN = -CN C C SET H1 + H2*I TO PI/SIN(PI*Z) OR LOG(PI/SIN(PI*Z)) C 30 A1 = SN*A1 A2 = CN*A2 A = A1*A1 + A2*A2 IF (A .EQ. 0.D0) GO TO 200 IF (MO .NE. 0) GO TO 40 C H1 = A1/A H2 = -A2/A C = PI*ET H1 = C*H1 H2 = C*H2 GO TO 41 C 40 H1 = (DLPI + T) - 0.5D0*DLOG(A) H2 = -DATAN2(A2,A1) 41 IF (Z(2) .LT. 0.D0) GO TO 42 X = 1.0 - X Y = -Y GO TO 50 42 H2 = -H2 X = 1.0 - X C----------------------------------------------------------------------- C CASE WHEN THE REAL PART OF Z IS NONNEGATIVE C----------------------------------------------------------------------- 50 W1 = 0.D0 W2 = 0.D0 N = 0 T = X Y2 = Y*Y A = T*T + Y2 CUT = 225.D0 IF (EPS .GT. 1.D-30) CUT = 144.D0 IF (EPS .GT. 1.D-20) CUT = 64.D0 IF (A .GE. CUT) GO TO 80 IF (A .EQ. 0.D0) GO TO 200 51 N = N + 1 T = T + 1.D0 A = T*T + Y2 IF (A .LT. CUT) GO TO 51 C C LET S1 + S2*I BE THE PRODUCT OF THE TERMS (Z+J)/(Z+N) C U1 = (X*T + Y2)/A U2 = Y/A S1 = U1 S2 = N*U2 IF (N .LT. 2) GO TO 70 U = T/A NM1 = N - 1 DO 60 J = 1,NM1 V1 = U1 + J*U V2 = (N - J)*U2 C = S1*V1 - S2*V2 D = S1*V2 + S2*V1 S1 = C S2 = D 60 CONTINUE C C SET W1 + W2*I = LOG(S1 + S2*I) WHEN MO IS NONZERO C 70 S = S1*S1 + S2*S2 IF (MO .EQ. 0) GO TO 80 W1 = 0.5D0 * DLOG(S) W2 = DATAN2(S2,S1) C C SET V1 + V2*I = (Z - 0.5) * LOG(Z + N) - Z C 80 T1 = 0.5D0 * DLOG(A) - 1.D0 T2 = DATAN2(Y,T) U = X - 0.5D0 V1 = (U*T1 - 0.5D0) - Y*T2 V2 = U*T2 + Y*T1 C C LET A1 + A2*I BE THE ASYMPTOTIC SUM C U1 = T/A U2 = -Y/A Q1 = U1*U1 - U2*U2 Q2 = 2.D0*U1*U2 A1 = 0.D0 A2 = 0.D0 DO 91 J = 1,30 T1 = A1 T2 = A2 A1 = A1 + C0(J)*U1 A2 = A2 + C0(J)*U2 IF (A1 .NE. T1) GO TO 90 IF (A2 .EQ. T2) GO TO 100 90 T1 = U1*Q1 - U2*Q2 T2 = U1*Q2 + U2*Q1 U1 = T1 U2 = T2 91 CONTINUE C----------------------------------------------------------------------- C GATHERING TOGETHER THE RESULTS C----------------------------------------------------------------------- 100 W1 = (((A1 + HL2P) - W1) + V1) - N W2 = (A2 - W2) + V2 IF (Z(1) .LT. 0.D0) GO TO 120 IF (MO .NE. 0) GO TO 110 C C CASE WHEN THE REAL PART OF Z IS NONNEGATIVE AND MO = 0 C A = DEXP(W1) W1 = A * DCOS(W2) W2 = A * DSIN(W2) IF (N .EQ. 0) GO TO 140 C = (S1*W1 + S2*W2)/S D = (S1*W2 - S2*W1)/S W1 = C W2 = D GO TO 140 C C CASE WHEN THE REAL PART OF Z IS NONNEGATIVE AND MO IS NONZERO. C THE ANGLE W2 IS REDUCED TO THE INTERVAL -PI .LT. W2 .LE. PI. C 110 IF (W2 .GT. PI) GO TO 111 K = 0.5D0 - W2/PI2 W2 = W2 + PI2*K GO TO 140 111 K = W2/PI2 - 0.5D0 U = K + 1 W2 = W2 - PI2*U IF (W2 .LE. -PI) W2 = PI GO TO 140 C C CASE WHEN THE REAL PART OF Z IS NEGATIVE AND MO IS NONZERO C 120 IF (MO .EQ. 0) GO TO 130 W1 = H1 - W1 W2 = H2 - W2 GO TO 110 C C CASE WHEN THE REAL PART OF Z IS NEGATIVE AND MO = 0 C 130 A = DEXP(-W1) T1 = A * DCOS(-W2) T2 = A * DSIN(-W2) W1 = H1*T1 - H2*T2 W2 = H1*T2 + H2*T1 IF (N .EQ. 0) GO TO 140 C = W1*S1 - W2*S2 D = W1*S2 + W2*S1 W1 = C W2 = D C C TERMINATION C 140 W(1) = W1 W(2) = W2 RETURN C----------------------------------------------------------------------- C THE REQUESTED VALUE CANNOT BE COMPUTED C----------------------------------------------------------------------- 200 W(1) = 0.D0 W(2) = 0.D0 RETURN END DOUBLE PRECISION FUNCTION DGAMMA(A) C----------------------------------------------------------------------- C C EVALUATION OF THE GAMMA FUNCTION FOR C DOUBLE PRECISION ARGUMENTS C C ----------- C C DGAMMA(A) IS ASSIGNED THE VALUE 0 WHEN THE GAMMA FUNCTION CANNOT C BE COMPUTED. C C----------------------------------------------------------------------- C WRITTEN BY ALFRED H. MORRIS, JR. C NAVAL SURFACE WEAPONS CENTER C DAHLGREN, VIRGINIA C----------------------------------------------------------------------- DOUBLE PRECISION A, D, PI, S, T, X, W DOUBLE PRECISION DPMPAR, DSIN1, DGAM1, DPDEL, DXPARG C----------------------------------------------------------------------- C D = 0.5*(LN(2*PI) - 1) C----------------------------------------------------------------------- DATA PI /3.14159265358979323846264338327950D0/ DATA D /0.41893853320467274178032973640562D0/ C----------------------------------------------------------------------- DGAMMA = 0.D0 X = A IF (DABS(A) .GT. 20.D0) GO TO 60 C----------------------------------------------------------------------- C EVALUATION OF DGAMMA(A) FOR DABS(A) .LE. 20 C----------------------------------------------------------------------- T = 1.D0 N = X N = N - 1 C C LET T BE THE PRODUCT OF A-J WHEN A .GE. 2 C IF (N) 20,12,10 10 DO 11 J = 1,N X = X - 1.D0 11 T = X*T 12 X = X - 1.D0 GO TO 40 C C LET T BE THE PRODUCT OF A+J WHEN A .LT. 1 C 20 T = A IF (A .GT. 0.D0) GO TO 30 N = - N - 1 IF (N .EQ. 0) GO TO 22 DO 21 J = 1,N X = X + 1.D0 21 T = X*T 22 X = (X + 0.5D0) + 0.5D0 T = X*T IF (T .EQ. 0.D0) RETURN C 30 CONTINUE C C THE FOLLOWING CODE CHECKS IF 1/T CAN OVERFLOW. THIS C CODE MAY BE OMITTED IF DESIRED. C IF (DABS(T) .GE. 1.D-33) GO TO 40 IF (DABS(T)*DPMPAR(3) .LE. 1.000000001D0) RETURN DGAMMA = 1.D0/T RETURN C C COMPUTE DGAMMA(1 + X) FOR 0 .LE. X .LT. 1 C 40 DGAMMA = 1.D0/(1.D0 + DGAM1(X)) C C TERMINATION C IF (A .LT. 1.D0) GO TO 50 DGAMMA = DGAMMA * T RETURN 50 DGAMMA = DGAMMA / T RETURN C----------------------------------------------------------------------- C EVALUATION OF DGAMMA(A) FOR DABS(A) .GT. 20 C----------------------------------------------------------------------- 60 IF (DABS(A) .GE. 1.D3) RETURN IF (A .GT. 0.D0) GO TO 70 S = DSIN1(A)/PI IF (S .EQ. 0.D0) RETURN X = -A C C COMPUTE THE MODIFIED ASYMPTOTIC SUM C 70 W = DPDEL(X) C C FINAL ASSEMBLY C W = (D + W) + (X - 0.5D0)*(DLOG(X) - 1.D0) IF (W .GT. DXPARG(0)) RETURN DGAMMA = DEXP(W) IF (A .LT. 0.D0) DGAMMA = (1.D0/(DGAMMA*S))/X RETURN END DOUBLE PRECISION FUNCTION DPDEL(X) C----------------------------------------------------------------------- C C COMPUTATION OF THE FUNCTION DEL(X) FOR X .GE. 10 WHERE C LN(GAMMA(X)) = (X - 0.5)*LN(X) - X + 0.5*LN(2*PI) + DEL(X) C C -------- C C THE SERIES FOR DPDEL ON THE INTERVAL 0.0 TO 1.0 DERIVED BY C A.H. MORRIS FROM THE CHEBYSHEV SERIES IN THE SLATEC LIBRARY C OBTAINED BY WAYNE FULLERTON (LOS ALAMOS). C C----------------------------------------------------------------------- DOUBLE PRECISION X, A(15), T, W C----------------------------------------------------------------------- DATA A(1) / .833333333333333333333333333333D-01/, * A(2) /-.277777777777777777777777752282D-04/, * A(3) / .793650793650793650791732130419D-07/, * A(4) /-.595238095238095232389839236182D-09/, * A(5) / .841750841750832853294451671990D-11/, * A(6) /-.191752691751854612334149171243D-12/, * A(7) / .641025640510325475730918472625D-14/, * A(8) /-.295506514125338232839867823991D-15/, * A(9) / .179643716359402238723287696452D-16/, * A(10) /-.139228964661627791231203060395D-17/ DATA A(11) / .133802855014020915603275339093D-18/, * A(12) /-.154246009867966094273710216533D-19/, * A(13) / .197701992980957427278370133333D-20/, * A(14) /-.234065664793997056856992426667D-21/, * A(15) / .171348014966398575409015466667D-22/ C----------------------------------------------------------------------- T = (10.D0/X)**2 W = A(15) DO 10 I = 1,14 K = 15 - I W = T*W + A(K) 10 CONTINUE DPDEL = W/X RETURN END DOUBLE PRECISION FUNCTION DGAM1 (X) C----------------------------------------------------------------------- C EVALUATION OF 1/GAMMA(1 + X) - 1 FOR -0.5 .LE. X .LE. 1.5 C----------------------------------------------------------------------- C C THE FOLLOWING ARE THE FIRST 49 COEFFICIENTS OF THE MACLAURIN C EXPANSION FOR 1/GAMMA(1 + X) - 1. THE COEFFICIENTS ARE C CORRECT TO 40 DIGITS. THE COEFFICIENTS WERE OBTAINED BY C ALFRED H. MORRIS JR. (NAVAL SURFACE WARFARE CENTER) AND ARE C GIVEN HERE FOR REFERENCE. ONLY THE FIRST 14 COEFFICIENTS ARE C USED IN THIS CODE. C C ----------- C C DATA A(1) / .5772156649015328606065120900824024310422D+00/, C * A(2) /-.6558780715202538810770195151453904812798D+00/, C * A(3) /-.4200263503409523552900393487542981871139D-01/, C * A(4) / .1665386113822914895017007951021052357178D+00/, C * A(5) /-.4219773455554433674820830128918739130165D-01/, C * A(6) /-.9621971527876973562114921672348198975363D-02/, C * A(7) / .7218943246663099542395010340446572709905D-02/, C * A(8) /-.1165167591859065112113971084018388666809D-02/, C * A(9) /-.2152416741149509728157299630536478064782D-03/, C * A(10) / .1280502823881161861531986263281643233949D-03/ C DATA A(11) /-.2013485478078823865568939142102181838229D-04/, C * A(12) /-.1250493482142670657345359473833092242323D-05/, C * A(13) / .1133027231981695882374129620330744943324D-05/, C * A(14) /-.2056338416977607103450154130020572836513D-06/, C * A(15) / .6116095104481415817862498682855342867276D-08/, C * A(16) / .5002007644469222930055665048059991303045D-08/, C * A(17) /-.1181274570487020144588126565436505577739D-08/, C * A(18) / .1043426711691100510491540332312250191401D-09/, C * A(19) / .7782263439905071254049937311360777226068D-11/, C * A(20) /-.3696805618642205708187815878085766236571D-11/ C DATA A(21) / .5100370287454475979015481322863231802727D-12/, C * A(22) /-.2058326053566506783222429544855237419746D-13/, C * A(23) /-.5348122539423017982370017318727939948990D-14/, C * A(24) / .1226778628238260790158893846622422428165D-14/, C * A(25) /-.1181259301697458769513764586842297831212D-15/, C * A(26) / .1186692254751600332579777242928674071088D-17/, C * A(27) / .1412380655318031781555803947566709037086D-17/, C * A(28) /-.2298745684435370206592478580633699260285D-18/, C * A(29) / .1714406321927337433383963370267257066813D-19/, C * A(30) / .1337351730493693114864781395122268022875D-21/ C DATA A(31) /-.2054233551766672789325025351355733796682D-21/, C * A(32) / .2736030048607999844831509904330982014865D-22/, C * A(33) /-.1732356445910516639057428451564779799070D-23/, C * A(34) /-.2360619024499287287343450735427531007926D-25/, C * A(35) / .1864982941717294430718413161878666898946D-25/, C * A(36) /-.2218095624207197204399716913626860379732D-26/, C * A(37) / .1297781974947993668824414486330594165619D-27/, C * A(38) / .1180697474966528406222745415509971518560D-29/, C * A(39) /-.1124584349277088090293654674261439512119D-29/, C * A(40) / .1277085175140866203990206677751124647749D-30/ C DATA A(41) /-.7391451169615140823461289330108552823711D-32/, C * A(42) / .1134750257554215760954165259469306393009D-34/, C * A(43) / .4639134641058722029944804907952228463058D-34/, C * A(44) /-.5347336818439198875077418196709893320905D-35/, C * A(45) / .3207995923613352622861237279082794391090D-36/, C * A(46) /-.4445829736550756882101590352124643637401D-38/, C * A(47) /-.1311174518881988712901058494389922190237D-38/, C * A(48) / .1647033352543813886818259327906394145400D-39/, C * A(49) /-.1056233178503581218600561071538285049997D-40/ C C ----------- C C C = A(1) - 1 IS ALSO FREQUENTLY NEEDED. C HAS THE VALUE ... C C DATA C /-.4227843350984671393934879099175975689578D+00/ C C----------------------------------------------------------------------- DOUBLE PRECISION X, D, T, W, Z DOUBLE PRECISION A0, A1, B1, B2, B3, B4, B5, B6, B7, B8 DOUBLE PRECISION P0, P1, P2, P3, P4, P5, P6, Q1, Q2, Q3, Q4 DOUBLE PRECISION C, C0, C1, C2, C3, C4, C5, C6, C7, C8, C9, * C10, C11, C12, C13 C---------------------------- DATA A0 / .611609510448141581788D-08/, * A1 / .624730830116465516210D-08/ DATA B1 / .203610414066806987300D+00/, * B2 / .266205348428949217746D-01/, * B3 / .493944979382446875238D-03/, * B4 /-.851419432440314906588D-05/, * B5 /-.643045481779353022248D-05/, * B6 / .992641840672773722196D-06/, * B7 /-.607761895722825260739D-07/, * B8 / .195755836614639731882D-09/ C---------------------------- DATA P0 /.6116095104481415817861D-08/, * P1 /.6871674113067198736152D-08/, * P2 /.6820161668496170657918D-09/, * P3 /.4686843322948848031080D-10/, * P4 /.1572833027710446286995D-11/, * P5/-.1249441572276366213222D-12/, * P6 /.4343529937408594255178D-14/ DATA Q1 /.3056961078365221025009D+00/, * Q2 /.5464213086042296536016D-01/, * Q3 /.4956830093825887312020D-02/, * Q4 /.2692369466186361192876D-03/ C---------------------------- C C = C0 - 1 C---------------------------- DATA C /-.422784335098467139393487909917598D+00/ C---------------------------- DATA C0 / .577215664901532860606512090082402D+00/, * C1 /-.655878071520253881077019515145390D+00/, * C2 /-.420026350340952355290039348754298D-01/, * C3 / .166538611382291489501700795102105D+00/, * C4 /-.421977345555443367482083012891874D-01/, * C5 /-.962197152787697356211492167234820D-02/, * C6 / .721894324666309954239501034044657D-02/, * C7 /-.116516759185906511211397108401839D-02/, * C8 /-.215241674114950972815729963053648D-03/, * C9 / .128050282388116186153198626328164D-03/ DATA C10 /-.201348547807882386556893914210218D-04/, * C11 /-.125049348214267065734535947383309D-05/, * C12 / .113302723198169588237412962033074D-05/, * C13 /-.205633841697760710345015413002057D-06/ C---------------------------- T = X D = X - 0.5D0 IF (D .GT. 0.D0) T = D - 0.5D0 IF (T) 40,10,20 C 10 DGAM1 = 0.D0 RETURN C------------ C C CASE WHEN 0 .LT. T .LE. 0.5 C C W IS A MINIMAX APPROXIMATION FOR C THE SERIES A(15) + A(16)*T + ... C C------------ 20 W = ((((((P6*T + P5)*T + P4)*T + P3)*T + P2)*T + P1)*T + P0)/ * ((((Q4*T + Q3)*T + Q2)*T + Q1)*T + 1.D0) Z = (((((((((((((W*T + C13)*T + C12)*T + C11)*T + C10)*T + * C9)*T + C8)*T + C7)*T + C6)*T + C5)*T + C4)*T + * C3)*T + C2)*T + C1)*T + C0 C IF (D .GT. 0.D0) GO TO 30 DGAM1 = X*Z RETURN 30 DGAM1 = (T/X)*((Z - 0.5D0) - 0.5D0) RETURN C------------ C C CASE WHEN -0.5 .LE. T .LT. 0 C C W IS A MINIMAX APPROXIMATION FOR C THE SERIES A(15) + A(16)*T + ... C C------------ 40 W = (A1*T + A0)/((((((((B8*T + B7)*T + B6)*T + B5)*T + * B4)*T + B3)*T + B2)*T + B1)*T + 1.D0) Z = (((((((((((((W*T + C13)*T + C12)*T + C11)*T + C10)*T + * C9)*T + C8)*T + C7)*T + C6)*T + C5)*T + C4)*T + * C3)*T + C2)*T + C1)*T + C C IF (D .GT. 0.D0) GO TO 50 DGAM1 = X*((Z + 0.5D0) + 0.5D0) RETURN 50 DGAM1 = T*Z/X RETURN END DOUBLE PRECISION FUNCTION DGAMLN (A) C----------------------------------------------------------------------- C C EVALUATION OF LN(GAMMA(A)) FOR POSITIVE A C C----------------------------------------------------------------------- C WRITTEN BY ALFRED H. MORRIS C NAVAL SURFACE WEAPONS CENTER C DAHLGREN, VIRGINIA C----------------------------------------------------------------------- C D = 0.5*(LN(2*PI) - 1) C----------------------------------------------------------------------- DOUBLE PRECISION A, D, X, W DOUBLE PRECISION DGMLN1, DPDEL C-------------------------- DATA D /0.41893853320467274178032973640562D0/ C-------------------------- IF (A .GE. 0.5D0) GO TO 10 DGAMLN = DGMLN1(A) - DLOG(A) RETURN 10 IF (A .GT. 2.5D0) GO TO 20 X = A - 1.D0 IF (A .LT. 1.D0) X = (A - 0.5D0) - 0.5D0 DGAMLN = DGMLN1(X) RETURN C 20 IF (A .GE. 10.D0) GO TO 30 N = A - 1.5D0 X = A W = 1.D0 DO 21 I = 1,N X = X - 1.D0 21 W = X*W DGAMLN = DGMLN1(X - 1.D0) + DLOG(W) RETURN C 30 W = DPDEL(A) DGAMLN = (D + W) + (A - 0.5D0)*(DLOG(A) - 1.D0) END DOUBLE PRECISION FUNCTION DGMLN1 (X) C----------------------------------------------------------------------- C EVALUATION OF LN(GAMMA(1 + X)) FOR -0.5 .LE. X .LE. 1.5 C----------------------------------------------------------------------- DOUBLE PRECISION X, W DOUBLE PRECISION DGAM1, DLNREL C----------------------- W = DGAM1(X) DGMLN1 = - DLNREL(W) RETURN END SUBROUTINE CPSI (Z, W) C----------------------------------------------------------------------- C EVALUATION OF THE COMPLEX DIGAMMA FUNCTION C----------------------------------------------------------------------- COMPLEX Z, W COMPLEX ETA, ETA2, SUM REAL C0(12) DOUBLE PRECISION DS1, DS2 C---------------------------- C PI2 = 2*PI C---------------------------- DATA PI/3.14159265358979324/ DATA PI2/6.28318530717958648/ C---------------------------- DATA C0(1) /.833333333333333E-01/, C0(2) /-.833333333333333E-02/, * C0(3) /.396825396825397E-02/, C0(4) /-.416666666666667E-02/, * C0(5) /.757575757575758E-02/, C0(6) /-.210927960927961E-01/, * C0(7) /.833333333333333E-01/, C0(8) /-.443259803921569E+00/, * C0(9) /.305395433027012E+01/, C0(10)/-.264562121212121E+02/, * C0(11)/.281460144927536E+03/, C0(12)/-.360751054639805E+04/ C---------------------------- C C ****** MAX AND EPS ARE MACHINE DEPENDENT CONSTANTS. C MAX IS THE LARGEST POSITIVE INTEGER THAT MAY C BE USED, AND EPS IS THE SMALLEST REAL NUMBER C SUCH THAT 1.0 + EPS .GT. 1.0. C MAX = IPMPAR(3) EPS = SPMPAR(1) C C---------------------------- X = REAL(Z) Y = AIMAG(Z) IF (X .GE. 0.0) GO TO 40 C----------------------------------------------------------------------- C CASE WHEN THE REAL PART OF Z IS NEGATIVE C----------------------------------------------------------------------- Y = ABS(Y) T = -PI2*Y ET = EXP(T) C C SET A1 = (1 + ET)/2 AND A2 = (1 - ET)/2 C A1 = 0.5*(1.0 + ET) IF (T .LT. -0.15) GO TO 10 A2 = -0.5*REXP(T) GO TO 20 10 A2 = 0.5*(0.5 + (0.5 - ET)) C C COMPUTE SIN(PI*X) AND COS(PI*X), OR -SIN(PI*X) AND -COS(PI*X) C 20 IF (ABS(X) .GE. AMIN1(FLOAT(MAX), 1.0/EPS)) GO TO 100 K = ABS(X) U = X + K IF (U .LE. -0.5) U = 0.5 + (0.5 + U) U = PI*U SN = SIN(U) CN = COS(U) C C SET H1 + H2*I = PI*COT(PI*Z) C S1 = A1*SN S2 = A2*CN C1 = A1*CN C2 = -A2*SN S = S1*S1 + S2*S2 H1 = PI*(S1*C1 + S2*C2)/S H2 = PI*(S1*C2 - S2*C1)/S C IF (AIMAG(Z) .LT. 0.0) GO TO 30 X = 1.0 - X Y = -Y GO TO 40 30 H2 = -H2 X = 1.0 - X C----------------------------------------------------------------------- C CASE WHEN THE REAL PART OF Z IS NONNEGATIVE C----------------------------------------------------------------------- 40 T = X Y2 = Y*Y A = X*X + Y2 IF (A .EQ. 0.0) GO TO 100 C C LET S1 + S2*I BE THE SUM OF THE TERMS 1/(Z+J) FOR J = 0,1,...,N-1 C DS1 = 0.D0 DS2 = 0.D0 50 IF (A .GE. 36.0) GO TO 51 DS1 = DS1 + DBLE(T/A) DS2 = DS2 - DBLE(Y/A) T = T + 1.0 A = T*T + Y2 GO TO 50 51 S1 = DS1 S2 = DS2 C C SET W1 + W2*I = LOG(Z+N) C W1 = 0.5*ALOG(A) W2 = ATAN2(Y,T) C C LET A1 + A2*I BE THE ASYMPTOTIC SUM C ETA = CMPLX(T/A,-Y/A) ETA2 = ETA*ETA M = 12 L = M SUM = CMPLX(C0(M),0.0) DO 60 J = 2,M L = L - 1 SUM = CMPLX(C0(L),0.0) + SUM*ETA2 60 CONTINUE SUM = CMPLX(0.5,0.0)*ETA + ETA2*SUM A1 = REAL(SUM) A2 = AIMAG(SUM) C----------------------------------------------------------------------- C GATHERING TOGETHER THE RESULTS C----------------------------------------------------------------------- W1 = (W1 - S1) - A1 W2 = (W2 - A2) - S2 W = CMPLX(W1,W2) IF (REAL(Z) .GE. 0.0) RETURN W = CMPLX(W1 - H1, W2 - H2) RETURN C----------------------------------------------------------------------- C THE REQUESTED VALUE CANNOT BE COMPUTED C----------------------------------------------------------------------- 100 W = (0.0, 0.0) RETURN END REAL FUNCTION PSI(XX) C--------------------------------------------------------------------- C C EVALUATION OF THE DIGAMMA FUNCTION C C ----------- C C PSI(XX) IS ASSIGNED THE VALUE 0 WHEN THE DIGAMMA FUNCTION CANNOT C BE COMPUTED. C C THE MAIN COMPUTATION INVOLVES EVALUATION OF RATIONAL CHEBYSHEV C APPROXIMATIONS PUBLISHED IN MATH. COMP. 27, 123-127(1973) BY C CODY, STRECOK AND THACHER. C C--------------------------------------------------------------------- C PSI WAS WRITTEN AT ARGONNE NATIONAL LABORATORY FOR THE FUNPACK C PACKAGE OF SPECIAL FUNCTION SUBROUTINES. PSI WAS MODIFIED BY C A.H. MORRIS (NSWC). C--------------------------------------------------------------------- REAL P1(7), P2(4), Q1(6), Q2(4) DOUBLE PRECISION DX0 C--------------------------------------------------------------------- C C PIOV4 = PI/4 C DX0 = ZERO OF PSI TO EXTENDED PRECISION C C--------------------------------------------------------------------- DATA PIOV4/.785398163397448E0/ DATA DX0/1.461632144968362341262659542325721325D0/ C--------------------------------------------------------------------- C C COEFFICIENTS FOR RATIONAL APPROXIMATION OF C PSI(X) / (X - X0), 0.5 .LE. X .LE. 3.0 C C--------------------------------------------------------------------- DATA P1(1)/.895385022981970E-02/, P1(2)/.477762828042627E+01/, * P1(3)/.142441585084029E+03/, P1(4)/.118645200713425E+04/, * P1(5)/.363351846806499E+04/, P1(6)/.413810161269013E+04/, * P1(7)/.130560269827897E+04/ DATA Q1(1)/.448452573429826E+02/, Q1(2)/.520752771467162E+03/, * Q1(3)/.221000799247830E+04/, Q1(4)/.364127349079381E+04/, * Q1(5)/.190831076596300E+04/, Q1(6)/.691091682714533E-05/ C--------------------------------------------------------------------- C C COEFFICIENTS FOR RATIONAL APPROXIMATION OF C PSI(X) - LN(X) + 1 / (2*X), X .GT. 3.0 C C--------------------------------------------------------------------- DATA P2(1)/-.212940445131011E+01/, P2(2)/-.701677227766759E+01/, * P2(3)/-.448616543918019E+01/, P2(4)/-.648157123766197E+00/ DATA Q2(1)/ .322703493791143E+02/, Q2(2)/ .892920700481861E+02/, * Q2(3)/ .546117738103215E+02/, Q2(4)/ .777788548522962E+01/ C--------------------------------------------------------------------- C C MACHINE DEPENDENT CONSTANTS ... C C XMAX1 = THE SMALLEST POSITIVE FLOATING POINT CONSTANT C WITH ENTIRELY INTEGER REPRESENTATION. ALSO USED C AS NEGATIVE OF LOWER BOUND ON ACCEPTABLE NEGATIVE C ARGUMENTS AND AS THE POSITIVE ARGUMENT BEYOND WHICH C PSI MAY BE REPRESENTED AS ALOG(X). C C XSMALL = ABSOLUTE ARGUMENT BELOW WHICH PI*COTAN(PI*X) C MAY BE REPRESENTED BY 1/X. C C--------------------------------------------------------------------- XMAX1 = IPMPAR(3) XMAX1 = AMIN1(XMAX1, 1.0/SPMPAR(1)) XSMALL = 1.E-9 C--------------------------------------------------------------------- X = XX AUG = 0.0E0 IF (X .GE. 0.5E0) GO TO 200 C--------------------------------------------------------------------- C X .LT. 0.5, USE REFLECTION FORMULA C PSI(1-X) = PSI(X) + PI * COTAN(PI*X) C--------------------------------------------------------------------- IF (ABS(X) .GT. XSMALL) GO TO 100 IF (X .EQ. 0.0E0) GO TO 400 C--------------------------------------------------------------------- C 0 .LT. ABS(X) .LE. XSMALL. USE 1/X AS A SUBSTITUTE C FOR PI*COTAN(PI*X) C--------------------------------------------------------------------- AUG = -1.0E0 / X GO TO 150 C--------------------------------------------------------------------- C REDUCTION OF ARGUMENT FOR COTAN C--------------------------------------------------------------------- 100 W = - X SGN = PIOV4 IF (W .GT. 0.0E0) GO TO 120 W = - W SGN = -SGN C--------------------------------------------------------------------- C MAKE AN ERROR EXIT IF X .LE. -XMAX1 C--------------------------------------------------------------------- 120 IF (W .GE. XMAX1) GO TO 400 NQ = INT(W) W = W - FLOAT(NQ) NQ = INT(W*4.0E0) W = 4.0E0 * (W - FLOAT(NQ) * .25E0) C--------------------------------------------------------------------- C W IS NOW RELATED TO THE FRACTIONAL PART OF 4.0 * X. C ADJUST ARGUMENT TO CORRESPOND TO VALUES IN FIRST C QUADRANT AND DETERMINE SIGN C--------------------------------------------------------------------- N = NQ / 2 IF ((N+N) .NE. NQ) W = 1.0E0 - W Z = PIOV4 * W M = N / 2 IF ((M+M) .NE. N) SGN = - SGN C--------------------------------------------------------------------- C DETERMINE FINAL VALUE FOR -PI*COTAN(PI*X) C--------------------------------------------------------------------- N = (NQ + 1) / 2 M = N / 2 M = M + M IF (M .NE. N) GO TO 140 C--------------------------------------------------------------------- C CHECK FOR SINGULARITY C--------------------------------------------------------------------- IF (Z .EQ. 0.0E0) GO TO 400 C--------------------------------------------------------------------- C USE COS/SIN AS A SUBSTITUTE FOR COTAN, AND C SIN/COS AS A SUBSTITUTE FOR TAN C--------------------------------------------------------------------- AUG = SGN * ((COS(Z) / SIN(Z)) * 4.0E0) GO TO 150 140 AUG = SGN * ((SIN(Z) / COS(Z)) * 4.0E0) 150 X = 1.0E0 - X 200 IF (X .GT. 3.0E0) GO TO 300 C--------------------------------------------------------------------- C 0.5 .LE. X .LE. 3.0 C--------------------------------------------------------------------- DEN = X UPPER = P1(1) * X C DO 210 I = 1, 5 DEN = (DEN + Q1(I)) * X UPPER = (UPPER + P1(I+1)) * X 210 CONTINUE C DEN = (UPPER + P1(7)) / (DEN + Q1(6)) XMX0 = DBLE(X) - DX0 PSI = DEN * XMX0 + AUG RETURN C--------------------------------------------------------------------- C IF X .GE. XMAX1, PSI = LN(X) C--------------------------------------------------------------------- 300 IF (X .GE. XMAX1) GO TO 350 C--------------------------------------------------------------------- C 3.0 .LT. X .LT. XMAX1 C--------------------------------------------------------------------- W = 1.0E0 / (X * X) DEN = W UPPER = P2(1) * W C DO 310 I = 1, 3 DEN = (DEN + Q2(I)) * W UPPER = (UPPER + P2(I+1)) * W 310 CONTINUE C AUG = UPPER / (DEN + Q2(4)) - 0.5E0 / X + AUG 350 PSI = AUG + ALOG(X) RETURN C--------------------------------------------------------------------- C ERROR RETURN C--------------------------------------------------------------------- 400 PSI = 0.0E0 RETURN END SUBROUTINE DCPSI (Z, W) C----------------------------------------------------------------------- C EVALUATION OF THE COMPLEX DIGAMMA FUNCTION C----------------------------------------------------------------------- DOUBLE PRECISION Z(2), W(2) DOUBLE PRECISION C0(30), PI, PI2 DOUBLE PRECISION A, A1, A2, CN, CUT, C1, C2, EPS, ET, H1, H2, * Q1, Q2, S, SN, S1, S2, T, T1, T2, U, U1, U2, * V1, V2, W1, W2, X, Y, Y2 DOUBLE PRECISION DREXP, DPMPAR C---------------------------- C PI2 = 2*PI C---------------------------- DATA PI /3.141592653589793238462643383279502884197D0/ DATA PI2 /6.283185307179586476925286766559005768394D0/ C---------------------------- DATA C0(1) / .8333333333333333333333333333333333333333D-01/, * C0(2) /-.8333333333333333333333333333333333333333D-02/, * C0(3) / .3968253968253968253968253968253968253968D-02/, * C0(4) /-.4166666666666666666666666666666666666667D-02/, * C0(5) / .7575757575757575757575757575757575757576D-02/, * C0(6) /-.2109279609279609279609279609279609279609D-01/, * C0(7) / .8333333333333333333333333333333333333333D-01/, * C0(8) /-.4432598039215686274509803921568627450980D+00/, * C0(9) / .3053954330270119743803954330270119743804D+01/, * C0(10) /-.2645621212121212121212121212121212121212D+02/ DATA C0(11) / .2814601449275362318840579710144927536232D+03/, * C0(12) /-.3607510546398046398046398046398046398046D+04/, * C0(13) / .5482758333333333333333333333333333333333D+05/, * C0(14) /-.9749368238505747126436781609195402298851D+06/, * C0(15) / .2005269579668807894614346227249453055905D+08/, * C0(16) /-.4723848677216299019607843137254901960784D+09/, * C0(17) / .1263572479591666666666666666666666666667D+11/, * C0(18) /-.3808793112524536881155302207933786881155D+12/, * C0(19) / .1285085049930508333333333333333333333333D+14/, * C0(20) /-.4824144835485017037158167036215816703622D+15/ DATA C0(21) / .2004031065651625273810842166323893898645D+17/, * C0(22) /-.9167743603195330775699275362318840579710D+18/, * C0(23) / .4597988834365650349043794326241134751773D+20/, * C0(24) /-.2518047192145109569708902332022552610788D+22/, * C0(25) / .1500173349215392873371144015151515151515D+24/, * C0(26) /-.9689957887463594065649794289465408805031D+25/, * C0(27) / .6764588237929282099094524230179847767567D+27/, * C0(28) /-.5089065946866228968976633291591192528736D+29/, * C0(29) / .4114728879255797869766548606761933615819D+31/, * C0(30) /-.3566658209537555610968457460865182898779D+33/ C---------------------------- C C ****** MAX AND EPS ARE MACHINE DEPENDENT CONSTANTS. C MAX IS THE LARGEST POSITIVE INTEGER THAT MAY C BE USED, AND EPS IS THE SMALLEST REAL NUMBER C SUCH THAT 1.D0 + EPS .GT. 1.D0. C MAX = IPMPAR(3) EPS = DPMPAR(1) C C---------------------------- X = Z(1) Y = Z(2) IF (X .GE. 0.D0) GO TO 40 C----------------------------------------------------------------------- C CASE WHEN THE REAL PART OF Z IS NEGATIVE C----------------------------------------------------------------------- Y = DABS(Y) T = -PI2*Y ET = DEXP(T) C C SET A1 = (1 + ET)/2 AND A2 = (1 - ET)/2 C A1 = 0.5D0*(1.D0 + ET) IF (T .LT. -0.15D0) GO TO 10 A2 = -0.5D0*DREXP(T) GO TO 20 10 A2 = 0.5D0*(0.5D0 + (0.5D0 - ET)) C C COMPUTE SIN(PI*X) AND COS(PI*X), OR -SIN(PI*X) AND -COS(PI*X) C 20 U = MAX IF (DABS(X) .GE. DMIN1(U, 1.D0/EPS)) GO TO 100 K = DABS(X) U = X + K IF (U .LE. -0.5D0) U = 0.5D0 + (0.5D0 + U) U = PI*U SN = DSIN(U) CN = DCOS(U) C C SET H1 + H2*I = PI*COT(PI*Z) C S1 = A1*SN S2 = A2*CN C1 = A1*CN C2 = -A2*SN S = S1*S1 + S2*S2 H1 = PI*(S1*C1 + S2*C2)/S H2 = PI*(S1*C2 - S2*C1)/S C IF (Z(2) .LT. 0.D0) GO TO 30 X = 1.D0 - X Y = -Y GO TO 40 30 H2 = -H2 X = 1.D0 - X C----------------------------------------------------------------------- C CASE WHEN THE REAL PART OF Z IS NONNEGATIVE C----------------------------------------------------------------------- 40 T = X Y2 = Y*Y A = X*X + Y2 IF (A .EQ. 0.D0) GO TO 100 CUT = 225.D0 IF (EPS .GT. 1.D-30) CUT = 144.D0 C C LET S1 + S2*I BE THE SUM OF THE TERMS 1/(Z+J) FOR J = 0,1,...,N-1 C S1 = 0.D0 S2 = 0.D0 50 IF (A .GE. CUT) GO TO 51 S1 = S1 + T/A S2 = S2 - Y/A T = T + 1.D0 A = T*T + Y2 GO TO 50 51 CONTINUE C C SET W1 + W2*I = LOG(Z+N) C W1 = 0.5D0*DLOG(A) W2 = DATAN2(Y,T) C C LET A1 + A2*I BE THE ASYMPTOTIC SUM C U1 = T/A U2 = -Y/A Q1 = U1*U1 - U2*U2 Q2 = 2.D0*U1*U2 V1 = Q1 V2 = Q2 A1 = 0.D0 A2 = 0.D0 M = 30 IF (EPS .GT. 1.D-30) M = 25 DO 61 J = 1,M T1 = A1 T2 = A2 A1 = A1 + C0(J)*V1 A2 = A2 + C0(J)*V2 IF (A1 .NE. T1) GO TO 60 IF (A2 .EQ. T2) GO TO 70 60 T1 = V1*Q1 - V2*Q2 T2 = V1*Q2 + V2*Q1 V1 = T1 61 V2 = T2 C----------------------------------------------------------------------- C GATHERING TOGETHER THE RESULTS C----------------------------------------------------------------------- 70 A1 = A1 + 0.5D0*U1 A2 = A2 + 0.5D0*U2 W(1) = (W1 - A1) - S1 W(2) = (W2 - A2) - S2 IF (Z(1) .GE. 0.D0) RETURN W(1) = W(1) - H1 W(2) = W(2) - H2 RETURN C----------------------------------------------------------------------- C THE REQUESTED VALUE CANNOT BE COMPUTED C----------------------------------------------------------------------- 100 W(1) = 0.D0 W(2) = 0.D0 RETURN END DOUBLE PRECISION FUNCTION DPSI(A) C----------------------------------------------------------------------- C C EVALUATION OF THE DIGAMMA FUNCTION FOR C DOUBLE PRECISION ARGUMENTS C C ----------- C C DPSI(A) IS ASSIGNED THE VALUE 0 WHEN THE DIGAMMA FUNCTION CANNOT C BE COMPUTED. C C----------------------------------------------------------------------- C WRITTEN BY ALFRED H. MORRIS, JR. C NAVAL SURFACE WARFARE CENTER C DAHLGREN, VIRGINIA C----------------------------------------------------------------------- C C THE SERIES FOR DPSI ON THE INTERVAL 0.0 TO 1.0 WAS DERIVED C BY WAYNE FULLERTON (LOS ALAMOS NATIONAL LABORATORY). C C WITH WEIGHTED ERROR 5.79E-32 C LOG WEIGHTED ERROR 31.24 C SIGNIFICANT FIGURES REQUIRED 30.93 C DECIMAL PLACES REQUIRED 32.05 C C THE SERIES FOR A .GE. 10 WAS DERIVED BY A.H. MORRIS FROM C THE CHEBYSHEV SERIES IN THE SLATEC LIBRARY OBTAINED BY WAYNE C FULLERTON (LOS ALAMOS). C C----------------------------------------------------------------------- DOUBLE PRECISION A, C(42), EPS, P(15), PI, S, T, X, X0, XMAX, W DOUBLE PRECISION DCSEVL, DPSI0, DPMPAR C---------------------------- DATA PI /3.1415926535897932384626433832795D0/ DATA X0 /.46163214496836234126265954232572D0/ C---------------------------- DATA C(1) / -.38057080835217921520437677667039D-01/, * C(2) / .49141539302938712748204699654277D+00/, * C(3) / -.56815747821244730242892064734081D-01/, * C(4) / .83578212259143131362775650747862D-02/, * C(5) / -.13332328579943425998079274172393D-02/, * C(6) / .22031328706930824892872397979521D-03/, * C(7) / -.37040238178456883592889086949229D-04/, * C(8) / .62837936548549898933651418717690D-05/, * C(9) / -.10712639085061849855283541747074D-05/, * C(10) / .18312839465484165805731589810378D-06/ DATA C(11) / -.31353509361808509869005779796885D-07/, * C(12) / .53728087762007766260471919143615D-08/, * C(13) / -.92116814159784275717880632624730D-09/, * C(14) / .15798126521481822782252884032823D-09/, * C(15) / -.27098646132380443065440589409707D-10/, * C(16) / .46487228599096834872947319529549D-11/, * C(17) / -.79752725638303689726504797772737D-12/, * C(18) / .13682723857476992249251053892838D-12/, * C(19) / -.23475156060658972717320677980719D-13/, * C(20) / .40276307155603541107907925006281D-14/ DATA C(21) / -.69102518531179037846547422974771D-15/, * C(22) / .11856047138863349552929139525768D-15/, * C(23) / -.20341689616261559308154210484223D-16/, * C(24) / .34900749686463043850374232932351D-17/, * C(25) / -.59880146934976711003011081393493D-18/, * C(26) / .10273801628080588258398005712213D-18/, * C(27) / -.17627049424561071368359260105386D-19/, * C(28) / .30243228018156920457454035490133D-20/, * C(29) / -.51889168302092313774286088874666D-21/, * C(30) / .89027730345845713905005887487999D-22/ DATA C(31) / -.15274742899426728392894971904000D-22/, * C(32) / .26207314798962083136358318079999D-23/, * C(33) / -.44964642738220696772598388053333D-24/, * C(34) / .77147129596345107028919364266666D-25/, * C(35) / -.13236354761887702968102638933333D-25/, * C(36) / .22709994362408300091277311999999D-26/, * C(37) / -.38964190215374115954491391999999D-27/, * C(38) / .66851981388855302310679893333333D-28/, * C(39) / -.11469986654920864872529919999999D-28/, * C(40) / .19679385886541405920515413333333D-29/ DATA C(41) / -.33764488189750979801907200000000D-30/, * C(42) / .57930703193214159246677333333333D-31/ C---------------------------- DATA P(1) / .833333333333333333333333333147D-03/, * P(2) /-.833333333333333333333317475057D-06/, * P(3) / .396825396825396825343072884056D-08/, * P(4) /-.416666666666666570859890514548D-10/, * P(5) / .757575757575654146210665696401D-12/, * P(6) /-.210927960920616064592099772274D-13/, * P(7) / .833333329719356554828382131321D-15/, * P(8) /-.443259676504784387819140445894D-16/, * P(9) / .305392145578967948828783519552D-17/, * P(10) /-.264499326810660590871410866039D-18/ DATA P(11) / .280568932535744579536244004181D-19/, * P(12) /-.351388195869099967789469969066D-20/, * P(13) / .476233402067211507540059750399D-21/, * P(14) /-.575024569953144855161645738666D-22/, * P(15) / .416180125797657207803740160000D-23/ C---------------------------- C C ****** XMAX, MAX, AND EPS ARE MACHINE DEPENDENT CONSTANTS. C XMAX IS THE LARGEST POSITIVE REAL NUMBER THAT MAY C BE USED, MAX IS THE LARGEST POSITIVE INTEGER THAT C MAY BE USED, AND EPS IS THE SMALLEST REAL NUMBER C SUCH THAT 1.D0 + EPS .GT. 1.D0. C MAX = IPMPAR(3) EPS = DPMPAR(1) XMAX = DPMPAR(3) C C---------------------------- DPSI = 0.D0 X = A IF (DABS(A) .GE. 10.D0) GO TO 60 C----------------------------------------------------------------------- C EVALUATION OF DPSI(A) FOR DABS(A) .LT. 10 C----------------------------------------------------------------------- T = 0.D0 N = X N = N - 1 C C LET T BE THE SUM OF 1/(A-J) WHEN A .GE. 2 C IF (N) 20,12,10 10 DO 11 J = 1,N X = X - 1.D0 T = 1.D0/X + T 11 CONTINUE 12 X = X - 1.D0 GO TO 40 C C CHECK IF 1/A CAN OVERFLOW C 20 IF (DABS(A) .GE. 1.D-35) GO TO 30 IF (DABS(A)*XMAX .LE. 1.000000001D0) RETURN C C LET T BE THE SUM OF -1/(A+J) WHEN A .LT. 1 C 30 T = -1.D0/A IF (A .GT. 0.D0) GO TO 40 N = - N - 1 IF (N .EQ. 0) GO TO 32 DO 31 J = 1,N X = X + 1.D0 IF (X .EQ. 0.D0) RETURN T = T - 1.D0/X 31 CONTINUE 32 X = (X + 0.5D0) + 0.5D0 IF (X .EQ. 0.D0) RETURN T = T - 1.D0/X C C COMPUTE T + DPSI(1 + X) FOR 0 .LE. X .LT. 1 C 40 IF (DABS(X - X0) .GT. 2.D-2) GO TO 50 DPSI = T + DPSI0(1.D0 + X) RETURN 50 K = 42 IF (EPS .GT. 1.D-20) K = 28 DPSI = T + DCSEVL (2.D0*X - 1.D0, C, K) RETURN C----------------------------------------------------------------------- C EVALUATION OF DPSI(A) FOR DABS(A) .GE. 10 C----------------------------------------------------------------------- 60 IF (A .GT. 0.D0) GO TO 70 T = MAX IF (DABS(A) .GE. DMIN1(T, 1.D0/EPS)) RETURN C C SET W = PI*COT(PI*A) WHEN A IS NEGATIVE C K = DABS(A) T = A + K IF (T .EQ. 0.D0) RETURN IF (T .LE. -0.5D0) T = 1.D0 + T T = PI*T W = PI*(DCOS(T)/DSIN(T)) X = 1.D0 - X C C COMPUTE THE MODIFIED ASYMPTOTIC SUM C 70 T = (10.D0/X)**2 S = P(15) DO 71 J = 1,14 L = 15 - J S = P(L) + T*S 71 CONTINUE S = 0.5D0/X + T*S C C FINAL ASSEMBLY C DPSI = DLOG(X) - S IF (A .LT. 0.D0) DPSI = DPSI - W RETURN END DOUBLE PRECISION FUNCTION DPSI0 (X) C----------------------------------------------------------------------- C C TAYLOR SERIES EXPANSION OF PSI(X) AROUND X0, C WHERE X0 IS THE ZERO OF PSI(X). C C------------------------- C WRITTEN BY A.H. MORRIS C NAVAL SURFACE WARFARE CENTER C DAHLGREN, VIRGINIA C----------------------------------------------------------------------- DOUBLE PRECISION A(20), H, X, W DOUBLE PRECISION DK1, DK2, DK3, DB, DB2, DX C------------------------- DATA DK1 /100442596182.D0/, DK2 /51069247913.D0/, * DK3 /53827985572.D0/ DATA DB /68719476736.D0/ DATA DX /.28939299282041499433886199389507989269636D-32/ C------------------------- DATA A(1) / .967672245447621170427444761710D+00/, * A(2) /-.442763168983592106092865281853D+00/, * A(3) / .258499760955651010624401385701D+00/, * A(4) /-.163942705442406527504251292747D+00/, * A(5) / .107824050691262365757182948867D+00/, * A(6) /-.721995612564547109261217836051D-01/, * A(7) / .488042881641431072250925255079D-01/, * A(8) /-.331611264748473592922583984045D-01/, * A(9) / .225976482322181046596248251178D-01/, * A(10) /-.154247659049489591388003168412D-01/ DATA A(11) / .105387916166121753881240498824D-01/, * A(12) /-.720453438635686824097047437040D-02/, * A(13) / .492678139572985344635426640268D-02/, * A(14) /-.336980165543932808279285672353D-02/, * A(15) / .230512632673492783693838028298D-02/, * A(16) /-.157693677143019725927093497173D-02/, * A(17) / .107882520191629658069191777474D-02/, * A(18) /-.738070938996005129566047389379D-03/, * A(19) / .504953265834602035177398177463D-03/, * A(20) /-.345468025106307699555567970882D-03/ C------------------------- C C SET H = X - X0 WHERE X0 IS THE ZERO OF PSI(X). X0 HAS THE C APPROXIMATE 60 DIGIT VALUE ... C C 1.4616321449683623412 62659542325721328468 19620400644635129598 C C A MORE ACCURATE VALUE IS GIVEN BY ... C C X0 = DK1/8**12 + DK2/8**24 + DK3/8**36 + DX C C THE FOLLOWING CODE SHOULD YIELD THE CORRECT VALUE FOR H IF A C BINARY, OCTAL, OR HEXADECIMAL DOUBLE PRECISION ARITHMETIC IS C BEING USED. C DB2 = DB*DB H = (((X - DK1/DB) - DK2/DB2) - DK3/(DB*DB2)) - DX C C------------------------- C N = 20 NM1 = N - 1 W = A(N) DO 10 I = 1,NM1 L = N - I W = A(L) + H*W 10 CONTINUE DPSI0 = H*W RETURN END SUBROUTINE PSIDF (X, N, M, ANS, IFLAG) C----------------------------------------------------------------------- C C PSIDF COMPUTES M MEMBER SEQUENCES OF SCALED DERIVATIVES OF C THE PSI FUNCTION C C W(K,X)=(-1)**(K+1)*PSI(K,X)/GAMMA(K+1) C C K=N,...,N+M-1 WHERE PSI(K,X) IS THE K-TH DERIVATIVE OF THE C PSI FUNCTION. C C THE BASIC METHOD OF EVALUATION IS THE ASYMPTOTIC EXPANSION C FOR LARGE X.GE.XMIN FOLLOWED BY BACKWARD RECURSION ON A TWO C TERM RECURSION RELATION C C W(X+1) + X**(-N-1) = W(X). C C THIS IS SUPPLEMENTED BY A SERIES C C SUM( (X+K)**(-N-1) , K=0,1,2,... ) C C WHICH CONVERGES RAPIDLY FOR LARGE N. BOTH XMIN AND THE C NUMBER OF TERMS OF THE SERIES ARE CALCULATED FROM THE UNIT C ROUND OFF OF THE MACHINE ENVIRONMENT. C C THE NOMINAL COMPUTATIONAL ACCURACY IS THE MAXIMUM OF UNIT C ROUNDOFF (=SPMPAR(1)) AND 1.0E-18 SINCE CRITICAL CONSTANTS C ARE GIVEN TO ONLY 18 DIGITS. C C DESCRIPTION OF ARGUMENTS C C INPUT C C X - ARGUMENT, X .GT. 0.0 C C N - FIRST MEMBER OF THE SEQUENCE, N .GE. 0 C C M - NUMBER OF MEMBERS OF THE SEQUENCE, M .GE. 1 C C OUTPUT C C ANS - A VECTOR OF LENGTH AT LEAST M WHOSE FIRST M C COMPONENTS ARE THE SCALED DERIVATIVES. C C IFLAG - A VARIABLE WHICH REPORTS THE STATUS OF THE C RESULTS. C IFLAG = 0 THE DESIRED VALUES WERE OBTAINED. C IFLAG = 1 AN INPUT ERROR WAS DETECTED. C IFLAG = 2 OVERFLOW. X TOO SMALL OR N+M-1 C TOO LARGE. C IFLAG = 3 UNDERFLOW. X TOO LARGE OR N+M-1 C TOO LARGE. C IFLAG = 4 N+M-1 IS TOO LARGE FOR THE CURRENT C VALUE OF X. THIS SETTING WILL NOT C OCCUR WHEN N+M-1 .LE. 100. C C----------------------------------------------------------------------- C WRITTEN BY DONALD E. AMOS C SANDIA LABORATORIES C JUNE 1982 C MODIFIED BY A. H. MORRIS (NSWC), 1990. C C REFERENCES ... C C (1) ACM TRANS. MATH SOFTWARE, 1983. C (2) HANDBOOK OF MATHEMATICAL FUNCTIONS, AMS 55, NATIONAL BUREAU C OF STANDARDS BY M. ABRAMOWITZ AND I.A. STEGUN, 1964, PP. C 258-260, EQUATIONS 6.3.5, 6.3.18, 6.4.6, 6.4.9, 6.4.10. C----------------------------------------------------------------------- REAL ALPHA, ARG, BETA, C, DEN, ELIM, EPS, FLN, FN, FNP, FNS, * FX, ND, RXSQ, S, T, TA, TK, TOL, TOLS, TSS, TST, TT, T1, * T2, WDTOL, X, XDMLN, XDMY, XINC, XLN, XM, XMIN REAL ANS(M), B(22), TRM(22), TRMR(100) REAL EPSLN, EXPARG, SPMPAR C------------------------ C C = 1/LN(10) C------------------------ DATA C /.43429/ DATA NMAX /100/ C----------------------------------------------------------------------- C BERNOULLI NUMBERS C----------------------------------------------------------------------- DATA B(1), B(2), B(3), B(4), B(5), B(6), B(7), B(8), B(9), B(10), * B(11), B(12), B(13), B(14), B(15), B(16), B(17), B(18), B(19), * B(20), B(21), B(22) /1.0, * -5.00000000000000000E-01,1.66666666666666667E-01, * -3.33333333333333333E-02,2.38095238095238095E-02, * -3.33333333333333333E-02,7.57575757575757576E-02, * -2.53113553113553114E-01,1.16666666666666667E+00, * -7.09215686274509804E+00,5.49711779448621554E+01, * -5.29124242424242424E+02,6.19212318840579710E+03, * -8.65802531135531136E+04,1.42551716666666667E+06, * -2.72982310678160920E+07,6.01580873900642368E+08, * -1.51163157670921569E+10,4.29614643061166667E+11, * -1.37116552050883328E+13,4.88332318973593167E+14, * -1.92965793419400681E+16/ C------------------------ IFLAG = 0 IF (X .LE. 0.0 .OR. N .LT. 0 .OR. M .LT. 1) GO TO 300 C NN = N + M - 1 FN = FLOAT(NN) FNP = FN + 1.0 EPS = SPMPAR(1) WDTOL = AMAX1(0.5*EPS, 0.5E-18) C----------------------------------------------------------------------- C ELIM = APPROXIMATE EXPONENTIAL OVER AND UNDERFLOW LIMIT C----------------------------------------------------------------------- ELIM = AMIN1(EXPARG(0), ABS(EXPARG(1))) - 6.906 XLN = ALOG(X) T = FNP*XLN C----------------------------------------------------------------------- C OVERFLOW AND UNDERFLOW TEST FOR SMALL AND LARGE X C----------------------------------------------------------------------- IF (ABS(T) .GT. ELIM) GO TO 310 IF (X .LT. WDTOL) GO TO 260 C----------------------------------------------------------------------- C COMPUTE XMIN AND THE NUMBER OF TERMS OF THE SERIES, FLN+1 C----------------------------------------------------------------------- ND = -C*EPSLN(0) ND = AMIN1(ND,18.0) FLN = ND - 3.0 ALPHA = 3.5 + 0.4*FLN BETA = 0.21 + FLN*(0.0006038*FLN + 0.008677) XM = ALPHA + BETA*FN MX = INT(XM) + 1 XMIN = FLOAT(MX) C IF (N .EQ. 0) GO TO 50 XM = -2.302*ND - AMIN1(0.0,XLN) FNS = FLOAT(N) ARG = XM/FNS ARG = AMIN1(0.0,ARG) EPS = EXP(ARG) XM = 1.0 - EPS IF (ABS(ARG) .LT. 1.0E-3) XM = -ARG FLN = X*XM/EPS XM = XMIN - X IF (XM .GT. 7.0 .AND. FLN .LT. 15.0) GO TO 200 C 50 XDMY = X XDMLN = XLN XINC = 0.0 IF (X .GE. XMIN) GO TO 60 NX = INT(X) XINC = XMIN - FLOAT(NX) XDMY = X + XINC XDMLN = ALOG(XDMY) 60 CONTINUE C----------------------------------------------------------------------- C GENERATE W(N+M-1,X) BY THE ASYMPTOTIC EXPANSION C----------------------------------------------------------------------- T = FN*XDMLN T1 = XDMLN + XDMLN T2 = T + XDMLN TK = AMAX1(ABS(T),ABS(T1),ABS(T2)) IF (TK .GT. ELIM) GO TO 320 C TSS = EXP(-T) TT = 0.5/XDMY T1 = TT TST = WDTOL*TT IF (NN .NE. 0) T1 = TT + 1.0/FN RXSQ = 1.0/(XDMY*XDMY) TA = 0.5*RXSQ T = FNP*TA S = T*B(3) IF (ABS(S) .LT. TST) GO TO 80 C TK = 2.0 DO 70 K = 4,22 T = T*((TK+FN + 1.0)/(TK + 1.0))*((TK+FN)/(TK + 2.0))*RXSQ TRM(K) = T*B(K) IF (ABS(TRM(K)) .LT. TST) GO TO 80 S = S + TRM(K) TK = TK + 2.0 70 CONTINUE C 80 S = (S + T1)*TSS IF (XINC .EQ. 0.0) GO TO 100 C----------------------------------------------------------------------- C BACKWARD RECUR FROM XDMY TO X C----------------------------------------------------------------------- NX = INT(XINC) NP = NN + 1 IF (NX .GT. NMAX) GO TO 330 IF (NN .EQ. 0) GO TO 160 XM = XINC - 1.0 FX = X + XM C----------------------------------------------------------------------- C THIS LOOP SHOULD NOT BE CHANGED. FX IS ACCURATE WHEN X IS SMALL C----------------------------------------------------------------------- DO 90 I = 1,NX TRMR(I) = FX**(-NP) S = S + TRMR(I) XM = XM - 1.0 FX = X + XM 90 CONTINUE C 100 ANS(M) = S IF (FN .EQ. 0.0) GO TO 180 C----------------------------------------------------------------------- C GENERATE LOWER DERIVATIVES, J.LT.N+M-1 C----------------------------------------------------------------------- IF (M .EQ. 1) RETURN DO 150 J = 2,M FNP = FN FN = FN - 1.0 TSS = TSS*XDMY T1 = TT IF (FN .NE. 0.0) T1 = TT + 1.0/FN T = FNP*TA S = T*B(3) IF (ABS(S) .LT. TST) GO TO 120 C TK = 3.0E0 + FNP DO 110 K = 4,22 TRM(K) = TRM(K)*FNP/TK IF (ABS(TRM(K)) .LT. TST) GO TO 120 S = S + TRM(K) TK = TK + 2.0 110 CONTINUE C 120 S = (S + T1)*TSS IF (XINC .EQ. 0.0) GO TO 140 IF (FN .EQ. 0.0) GO TO 160 XM = XINC - 1.0 FX = X + XM DO 130 I = 1,NX TRMR(I) = TRMR(I)*FX S = S + TRMR(I) XM = XM - 1.0 FX = X + XM 130 CONTINUE C 140 MX = M - J + 1 ANS(MX) = S IF (FN .EQ. 0.0) GO TO 180 150 CONTINUE RETURN C----------------------------------------------------------------------- C RECURSION FOR N = 0 C----------------------------------------------------------------------- 160 DO 170 I = 1,NX S = S + 1.0/(X + FLOAT(NX-I)) 170 CONTINUE C 180 ANS(1) = S - XDMLN RETURN C----------------------------------------------------------------------- C COMPUTE BY SERIES (X+K)**(-(N+1)) , K=0,1,2,... C----------------------------------------------------------------------- 200 NN = INT(FLN) + 1 NP = N + 1 T1 = (FNS + 1.0)*XLN T = EXP(-T1) S = T DEN = X DO 210 I = 1,NN DEN = DEN + 1.0 TRM(I) = DEN**(-NP) S = S + TRM(I) 210 CONTINUE ANS(1) = S IF (M .EQ. 1) RETURN C----------------------------------------------------------------------- C GENERATE HIGHER DERIVATIVES, J .GT. N C----------------------------------------------------------------------- TOL = WDTOL/5.0 DO 250 J = 2,M T = T/X S = T TOLS = T*TOL DEN = X DO 230 I = 1,NN DEN = DEN + 1.0 TRM(I) = TRM(I)/DEN S = S + TRM(I) IF (TRM(I) .LT. TOLS) GO TO 240 230 CONTINUE 240 ANS(J) = S 250 CONTINUE RETURN C----------------------------------------------------------------------- C SMALL X .LT. UNIT ROUND OFF C----------------------------------------------------------------------- 260 ANS(1) = X**(-N-1) IF (M .EQ. 1) RETURN K = 1 DO 270 I = 2,M ANS(K+1) = ANS(K)/X K = K + 1 270 CONTINUE RETURN C----------------------------------------------------------------------- C ERROR RETURN C----------------------------------------------------------------------- 300 IFLAG = 1 RETURN C 310 IF (T .GT. 0.0) GO TO 320 IFLAG = 2 RETURN C 320 IFLAG = 3 RETURN C INCREASE THE DIMENSION OF TRMR(NMAX) 330 IFLAG = 4 RETURN END REAL FUNCTION BETALN (A0, B0) C----------------------------------------------------------------------- C EVALUATION OF THE LOGARITHM OF THE BETA FUNCTION C----------------------------------------------------------------------- C E = 0.5*LN(2*PI) C-------------------------- DATA E /.918938533204673/ C-------------------------- A = AMIN1(A0,B0) B = AMAX1(A0,B0) IF (A .GE. 8.0) GO TO 60 IF (A .GE. 1.0) GO TO 20 C----------------------------------------------------------------------- C PROCEDURE WHEN A .LT. 1 C----------------------------------------------------------------------- IF (B .GE. 8.0) GO TO 10 BETALN = GAMLN(A) + (GAMLN(B) - GAMLN(A + B)) RETURN 10 BETALN = GAMLN(A) + ALGDIV(A,B) RETURN C----------------------------------------------------------------------- C PROCEDURE WHEN 1 .LE. A .LT. 8 C----------------------------------------------------------------------- 20 IF (A .GT. 2.0) GO TO 30 IF (B .GT. 2.0) GO TO 21 BETALN = GAMLN(A) + GAMLN(B) - GSUMLN(A,B) RETURN 21 W = 0.0 IF (B .LT. 8.0) GO TO 40 BETALN = GAMLN(A) + ALGDIV(A,B) RETURN C C REDUCTION OF A WHEN B .LE. 1000 C 30 IF (B .GT. 1000.0) GO TO 50 N = A - 1.0 W = 1.0 DO 31 I = 1,N A = A - 1.0 H = A/B W = W * (H/(1.0 + H)) 31 CONTINUE W = ALOG(W) IF (B .LT. 8.0) GO TO 40 BETALN = W + GAMLN(A) + ALGDIV(A,B) RETURN C C REDUCTION OF B WHEN B .LT. 8 C 40 N = B - 1.0 Z = 1.0 DO 41 I = 1,N B = B - 1.0 Z = Z * (B/(A + B)) 41 CONTINUE BETALN = W + ALOG(Z) + (GAMLN(A) + (GAMLN(B) - GSUMLN(A,B))) RETURN C C REDUCTION OF A WHEN B .GT. 1000 C 50 N = A - 1.0 W = 1.0 DO 51 I = 1,N A = A - 1.0 W = W * (A/(1.0 + A/B)) 51 CONTINUE BETALN = (ALOG(W) - N*ALOG(B)) + (GAMLN(A) + ALGDIV(A,B)) RETURN C----------------------------------------------------------------------- C PROCEDURE WHEN A .GE. 8 C----------------------------------------------------------------------- 60 W = BCORR(A,B) H = A/B C = H/(1.0 + H) U = -(A - 0.5)*ALOG(C) V = B*ALNREL(H) IF (U .LE. V) GO TO 61 BETALN = (((-0.5*ALOG(B) + E) + W) - V) - U RETURN 61 BETALN = (((-0.5*ALOG(B) + E) + W) - U) - V RETURN END REAL FUNCTION GSUMLN (A, B) C----------------------------------------------------------------------- C EVALUATION OF THE FUNCTION LN(GAMMA(A + B)) C FOR 1 .LE. A .LE. 2 AND 1 .LE. B .LE. 2 C----------------------------------------------------------------------- X = DBLE(A) + DBLE(B) - 2.D0 IF (X .GT. 0.25) GO TO 10 GSUMLN = GAMLN1(1.0 + X) RETURN 10 IF (X .GT. 1.25) GO TO 20 GSUMLN = GAMLN1(X) + ALNREL(X) RETURN 20 GSUMLN = GAMLN1(X - 1.0) + ALOG(X*(1.0 + X)) RETURN END REAL FUNCTION BCORR (A0, B0) C----------------------------------------------------------------------- C C EVALUATION OF DEL(A0) + DEL(B0) - DEL(A0 + B0) WHERE C LN(GAMMA(A)) = (A - 0.5)*LN(A) - A + 0.5*LN(2*PI) + DEL(A). C IT IS ASSUMED THAT A0 .GE. 8 AND B0 .GE. 8. C C----------------------------------------------------------------------- DATA C0/.833333333333333E-01/, C1/-.277777777760991E-02/, * C2/.793650666825390E-03/, C3/-.595202931351870E-03/, * C4/.837308034031215E-03/, C5/-.165322962780713E-02/ C------------------------ A = AMIN1(A0, B0) B = AMAX1(A0, B0) C H = A/B C = H/(1.0 + H) X = 1.0/(1.0 + H) X2 = X*X C C SET SN = (1 - X**N)/(1 - X) C S3 = 1.0 + (X + X2) S5 = 1.0 + (X + X2*S3) S7 = 1.0 + (X + X2*S5) S9 = 1.0 + (X + X2*S7) S11 = 1.0 + (X + X2*S9) C C SET W = DEL(B) - DEL(A + B) C T = (1.0/B)**2 W = ((((C5*S11*T + C4*S9)*T + C3*S7)*T + C2*S5)*T + C1*S3)*T + C0 W = W*(C/B) C C COMPUTE DEL(A) + W C T = (1.0/A)**2 BCORR = (((((C5*T + C4)*T + C3)*T + C2)*T + C1)*T + C0)/A + W RETURN END REAL FUNCTION ALGDIV (A, B) C----------------------------------------------------------------------- C C COMPUTATION OF LN(GAMMA(B)/GAMMA(A+B)) WHEN B .GE. 8 C C -------- C C IN THIS ALGORITHM, DEL(X) IS THE FUNCTION DEFINED BY C LN(GAMMA(X)) = (X - 0.5)*LN(X) - X + 0.5*LN(2*PI) + DEL(X). C C----------------------------------------------------------------------- DATA C0/.833333333333333E-01/, C1/-.277777777760991E-02/, * C2/.793650666825390E-03/, C3/-.595202931351870E-03/, * C4/.837308034031215E-03/, C5/-.165322962780713E-02/ C------------------------ IF (A .LE. B) GO TO 10 H = B/A C = 1.0/(1.0 + H) X = H/(1.0 + H) D = A + (B - 0.5) GO TO 20 10 H = A/B C = H/(1.0 + H) X = 1.0/(1.0 + H) D = B + (A - 0.5) C C SET SN = (1 - X**N)/(1 - X) C 20 X2 = X*X S3 = 1.0 + (X + X2) S5 = 1.0 + (X + X2*S3) S7 = 1.0 + (X + X2*S5) S9 = 1.0 + (X + X2*S7) S11 = 1.0 + (X + X2*S9) C C SET W = DEL(B) - DEL(A + B) C T = (1.0/B)**2 W = ((((C5*S11*T + C4*S9)*T + C3*S7)*T + C2*S5)*T + C1*S3)*T + C0 W = W*(C/B) C C COMBINE THE RESULTS C U = D*ALNREL(A/B) V = A*(ALOG(B) - 1.0) IF (U .LE. V) GO TO 30 ALGDIV = (W - V) - U RETURN 30 ALGDIV = (W - U) - V RETURN END DOUBLE PRECISION FUNCTION DBETLN (A0, B0) C----------------------------------------------------------------------- C EVALUATION OF THE LOGARITHM OF THE BETA FUNCTION C----------------------------------------------------------------------- DOUBLE PRECISION A0, B0 DOUBLE PRECISION A, B, C, E, H, SN, U, V, W, Z DOUBLE PRECISION DBCORR, DGAMLN, DGSMLN, DLGDIV, DLNREL C-------------------------- C E = 0.5*LN(2*PI) C-------------------------- DATA E /.9189385332046727417803297364056D0/ C-------------------------- A = DMIN1(A0,B0) B = DMAX1(A0,B0) IF (A .GE. 10.D0) GO TO 60 IF (A .GE. 1.D0) GO TO 20 C----------------------------------------------------------------------- C PROCEDURE WHEN A .LT. 1 C----------------------------------------------------------------------- IF (B .GE. 10.D0) GO TO 10 DBETLN = DGAMLN(A) + (DGAMLN(B) - DGAMLN(A + B)) RETURN 10 DBETLN = DGAMLN(A) + DLGDIV(A,B) RETURN C----------------------------------------------------------------------- C PROCEDURE WHEN 1 .LE. A .LT. 10 C----------------------------------------------------------------------- 20 IF (A .GT. 2.D0) GO TO 30 IF (B .GT. 2.D0) GO TO 21 DBETLN = DGAMLN(A) + DGAMLN(B) - DGSMLN(A,B) RETURN 21 W = 0.D0 IF (B .LT. 10.D0) GO TO 40 DBETLN = DGAMLN(A) + DLGDIV(A,B) RETURN C C REDUCTION OF A WHEN B .LE. 1000 C 30 IF (B .GT. 1.D3) GO TO 50 N = A - 1.D0 W = 1.D0 DO 31 I = 1,N A = A - 1.D0 H = A/B W = W * (H/(1.D0 + H)) 31 CONTINUE W = DLOG(W) IF (B .LT. 10.D0) GO TO 40 DBETLN = W + DGAMLN(A) + DLGDIV(A,B) RETURN C C REDUCTION OF B WHEN B .LT. 10 C 40 N = B - 1.D0 Z = 1.D0 DO 41 I = 1,N B = B - 1.D0 Z = Z * (B/(A + B)) 41 CONTINUE DBETLN = W + DLOG(Z) + (DGAMLN(A) + (DGAMLN(B) - DGSMLN(A,B))) RETURN C C REDUCTION OF A WHEN B .GT. 1000 C 50 N = A - 1.D0 W = 1.D0 DO 51 I = 1,N A = A - 1.D0 W = W*(A/(1.D0 + A/B)) 51 CONTINUE SN = N DBETLN = (DLOG(W) - SN*DLOG(B)) + (DGAMLN(A) + DLGDIV(A,B)) RETURN C----------------------------------------------------------------------- C PROCEDURE WHEN A .GE. 10 C----------------------------------------------------------------------- 60 W = DBCORR(A,B) H = A/B C = H/(1.D0 + H) U = -(A - 0.5D0)*DLOG(C) V = B*DLNREL(H) IF (U .LE. V) GO TO 61 DBETLN = (((-0.5D0*DLOG(B) + E) + W) - V) - U RETURN 61 DBETLN = (((-0.5D0*DLOG(B) + E) + W) - U) - V RETURN END DOUBLE PRECISION FUNCTION DGSMLN (A, B) C----------------------------------------------------------------------- C EVALUATION OF THE FUNCTION LN(GAMMA(A + B)) C FOR 1 .LE. A .LE. 2 AND 1 .LE. B .LE. 2 C----------------------------------------------------------------------- DOUBLE PRECISION A, B, X DOUBLE PRECISION DGMLN1, DLNREL C X = (A - 1.D0) + (B - 1.D0) IF (X .GT. 0.5D0) GO TO 10 DGSMLN = DGMLN1(1.D0 + X) RETURN 10 IF (X .GT. 1.5D0) GO TO 20 DGSMLN = DGMLN1(X) + DLNREL(X) RETURN 20 DGSMLN = DGMLN1(X - 1.D0) + DLOG(X*(1.D0 + X)) RETURN END DOUBLE PRECISION FUNCTION DBCORR (A0, B0) C----------------------------------------------------------------------- C C EVALUATION OF DEL(A) + DEL(B0) - DEL(A) + B0) WHERE C LN(GAMMA(X)) = (X - 0.5)*LN(X) - X + 0.5*LN(2*PI) + DEL(X). C IT IS ASSUMED THAT A0 .GE. 10 AND B0 .GE. 10. C C -------- C C THE SERIES FOR DEL(X), WHICH APPLIES FOR X .GE. 10, WAS C DERIVED BY A.H. MORRIS FROM THE CHEBYSHEV SERIES IN THE C SLATEC LIBRARY OBTAINED BY WAYNE FULLERTON (LOS ALAMOS). C C----------------------------------------------------------------------- DOUBLE PRECISION A0, B0 DOUBLE PRECISION A, B, C, E(15), H, S(15), T, W, X, X2, Z C-------------------------- DATA E(1) / .833333333333333333333333333333D-01/, * E(2) /-.277777777777777777777777752282D-04/, * E(3) / .793650793650793650791732130419D-07/, * E(4) /-.595238095238095232389839236182D-09/, * E(5) / .841750841750832853294451671990D-11/, * E(6) /-.191752691751854612334149171243D-12/, * E(7) / .641025640510325475730918472625D-14/, * E(8) /-.295506514125338232839867823991D-15/, * E(9) / .179643716359402238723287696452D-16/, * E(10) /-.139228964661627791231203060395D-17/ DATA E(11) / .133802855014020915603275339093D-18/, * E(12) /-.154246009867966094273710216533D-19/, * E(13) / .197701992980957427278370133333D-20/, * E(14) /-.234065664793997056856992426667D-21/, * E(15) / .171348014966398575409015466667D-22/ C-------------------------- A = DMIN1(A0, B0) B = DMAX1(A0, B0) C H = A/B C = H/(1.D0 + H) X = 1.D0/(1.D0 + H) X2 = X*X C C COMPUTE (1 - X**N)/(1 - X) FOR N = 1,3,5,... C STORE THESE VALUES IN S(1),S(2),... C S(1) = 1.D0 DO 10 J = 1,14 S(J + 1) = 1.D0 + (X + X2*S(J)) 10 CONTINUE C C SET W = DEL(B) - DEL(A + B) C T = (10.D0/B)**2 W = E(15)*S(15) DO 20 J = 1,14 K = 15 - J W = T*W + E(K)*S(K) 20 CONTINUE W = W*(C/B) C C COMPUTE DEL(A) + W C T = (10.D0/A)**2 Z = E(15) DO 30 J = 1,14 K = 15 - J Z = T*Z + E(K) 30 CONTINUE DBCORR = Z/A + W RETURN END DOUBLE PRECISION FUNCTION DLGDIV (A, B) C----------------------------------------------------------------------- C C COMPUTATION OF LN(GAMMA(B)/GAMMA(A+B)) FOR B .GE. 10 C C -------- C C DLGDIV USES A SERIES FOR THE FUNCTION DEL(X) WHERE C LN(GAMMA(X)) = (X - 0.5)*LN(X) - X + 0.5*LN(2*PI) + DEL(X). C THE SERIES FOR DEL(X), WHICH APPLIES FOR X .GE. 10, WAS C DERIVED BY A.H. MORRIS FROM THE CHEBYSHEV SERIES IN THE C SLATEC LIBRARY OBTAINED BY WAYNE FULLERTON (LOS ALAMOS). C C----------------------------------------------------------------------- DOUBLE PRECISION A, B DOUBLE PRECISION C, D, E(15), H, S(15), T, U, V, W, X, X2 DOUBLE PRECISION DLNREL C-------------------------- DATA E(1) / .833333333333333333333333333333D-01/, * E(2) /-.277777777777777777777777752282D-04/, * E(3) / .793650793650793650791732130419D-07/, * E(4) /-.595238095238095232389839236182D-09/, * E(5) / .841750841750832853294451671990D-11/, * E(6) /-.191752691751854612334149171243D-12/, * E(7) / .641025640510325475730918472625D-14/, * E(8) /-.295506514125338232839867823991D-15/, * E(9) / .179643716359402238723287696452D-16/, * E(10) /-.139228964661627791231203060395D-17/ DATA E(11) / .133802855014020915603275339093D-18/, * E(12) /-.154246009867966094273710216533D-19/, * E(13) / .197701992980957427278370133333D-20/, * E(14) /-.234065664793997056856992426667D-21/, * E(15) / .171348014966398575409015466667D-22/ C-------------------------- IF (A .LE. B) GO TO 10 H = B/A C = 1.D0/(1.D0 + H) X = H/(1.D0 + H) D = A + (B - 0.5D0) GO TO 20 10 H = A/B C = H/(1.D0 + H) X = 1.D0/(1.D0 + H) D = B + (A - 0.5D0) C C COMPUTE (1 - X**N)/(1 - X) FOR N = 1,3,5,... C STORE THESE VALUES IN S(1),S(2),... C 20 X2 = X*X S(1) = 1.D0 DO 21 J = 1,14 S(J + 1) = 1.D0 + (X + X2*S(J)) 21 CONTINUE C C SET W = DEL(B) - DEL(A + B) C T = (10.D0/B)**2 W = E(15)*S(15) DO 30 J = 1,14 K = 15 - J W = T*W + E(K)*S(K) 30 CONTINUE W = W*(C/B) C C COMBINE THE RESULTS C U = D*DLNREL(A/B) V = A*(DLOG(B) - 1.D0) IF (U .LE. V) GO TO 40 DLGDIV = (W - V) - U RETURN 40 DLGDIV = (W - U) - V RETURN END SUBROUTINE GRATIO (A, X, ANS, QANS, IND) C----------------------------------------------------------------------- C C EVALUATION OF THE INCOMPLETE GAMMA RATIO FUNCTIONS C P(A,X) AND Q(A,X) C C ---------- C C IT IS ASSUMED THAT A AND X ARE NONNEGATIVE, WHERE A AND X C ARE NOT BOTH 0. C C ANS AND QANS ARE VARIABLES. GRATIO ASSIGNS ANS THE VALUE C P(A,X) AND QANS THE VALUE Q(A,X). IND MAY BE ANY INTEGER. C IF IND = 0 THEN THE USER IS REQUESTING AS MUCH ACCURACY AS C POSSIBLE (UP TO 14 SIGNIFICANT DIGITS). OTHERWISE, IF C IND = 1 THEN ACCURACY IS REQUESTED TO WITHIN 1 UNIT OF THE C 6-TH SIGNIFICANT DIGIT, AND IF IND .NE. 0,1 THEN ACCURACY C IS REQUESTED TO WITHIN 1 UNIT OF THE 3RD SIGNIFICANT DIGIT. C C ERROR RETURN ... C C ANS IS ASSIGNED THE VALUE 2 WHEN A OR X IS NEGATIVE, C WHEN A*X = 0, OR WHEN P(A,X) AND Q(A,X) ARE INDETERMINANT. C P(A,X) AND Q(A,X) ARE COMPUTATIONALLY INDETERMINANT WHEN C X IS EXCEEDINGLY CLOSE TO A AND A IS EXTREMELY LARGE. C C----------------------------------------------------------------------- C WRITTEN BY ALFRED H. MORRIS, JR. C NAVAL SURFACE WARFARE CENTER C DAHLGREN, VIRGINIA C REVISED ... DEC 1991 C------------------------- REAL J, L, ACC0(3), BIG(3), E0(3), X0(3), WK(20) REAL A0(4), A1(4), A2(2), A3(2), A4(2), A5(2), A6(2), A7(2), * A8(2) REAL B0(6), B1(4), B2(5), B3(5), B4(4), B5(3), B6(2), B7(2) REAL D0(6), D1(4), D2(2), D3(2), D4(1), D5(1), D6(1) C------------------------- DATA ACC0(1)/5.E-15/, ACC0(2)/5.E-7/, ACC0(3)/5.E-4/ DATA BIG(1)/25.0/, BIG(2)/14.0/, BIG(3)/10.0/ DATA E0(1)/.25E-3/, E0(2)/.25E-1/, E0(3)/.14/ DATA X0(1)/31.0/, X0(2)/17.0/, X0(3)/9.7/ C------------------------- C ALOG10 = LN(10) C RT2PIN = 1/SQRT(2*PI) C RTPI = SQRT(PI) C------------------------- DATA ALOG10/2.30258509299405/ DATA RT2PIN/.398942280401433/ DATA RTPI /1.77245385090552/ C------------------------- C C COEFFICIENTS FOR MINIMAX APPROXIMATIONS C FOR C0,...,C8 C C------------------------- DATA A0(1) /-.231272501940775E-02/, A0(2)/-.335378520024220E-01/, * A0(3) /-.159840143443990E+00/, A0(4)/-.333333333333333E+00/ DATA B0(1) /.633763414209504E-06/, B0(2)/-.939001940478355E-05/, * B0(3) /.239521354917408E-02/, B0(4)/ .376245718289389E-01/, * B0(5) /.238549219145773E+00/, B0(6)/ .729520430331981E+00/ C------------------------- DATA A1(1) /-.398783924370770E-05/, A1(2)/-.587926036018402E-03/, * A1(3) /-.491687131726920E-02/, A1(4)/-.185185185184291E-02/ DATA B1(1) /.386325038602125E-02/, B1(2) /.506042559238939E-01/, * B1(3) /.283344278023803E+00/, B1(4) /.780110511677243E+00/ C------------------------- DATA A2(1) /.669564126155663E-03/, A2(2) /.413359788442192E-02/ DATA B2(1) /-.421924263980656E-03/, B2(2) /.650837693041777E-02/, * B2(3) / .682034997401259E-01/, B2(4) /.339173452092224E+00/, * B2(5) / .810647620703045E+00/ C------------------------- DATA A3(1) /.810586158563431E-03/, A3(2) /.649434157619770E-03/ DATA B3(1) /-.632276587352120E-03/, B3(2) /.905375887385478E-02/, * B3(3) / .906610359762969E-01/, B3(4) /.406288930253881E+00/, * B3(5) / .894800593794972E+00/ C------------------------- DATA A4(1) /-.105014537920131E-03/, A4(2)/-.861888301199388E-03/ DATA B4(1) /.322609381345173E-01/, B4(2) /.178295773562970E+00/, * B4(3) /.591353097931237E+00/, B4(4) /.103151890792185E+01/ C------------------------- DATA A5(1) /-.435211415445014E-03/, A5(2)/-.336806989710598E-03/ DATA B5(1) /.178716720452422E+00/, B5(2) /.600380376956324E+00/, * B5(3) /.108515217314415E+01/ C------------------------- DATA A6(1) /-.182503596367782E-03/, A6(2) /.531279816209452E-03/ DATA B6(1) /.345608222411837E+00/, B6(2) /.770341682526774E+00/ C------------------------- DATA A7(1) /.443219646726422E-03/, A7(2) /.344430064306926E-03/ DATA B7(1) /.821824741357866E+00/, B7(2) /.115029088777769E+01/ C------------------------- DATA A8(1) /.878371203603888E-03/, A8(2)/-.686013280418038E-03/ C------------------------- C C COEFFICIENTS FOR THE TEMME EXPANSION C C------------------------- DATA D00 /-.333333333333333E+00/, D0(1) / .833333333333333E-01/, * D0(2) /-.148148148148148E-01/, D0(3) / .115740740740741E-02/, * D0(4) / .352733686067019E-03/, D0(5) /-.178755144032922E-03/, * D0(6) / .391926317852244E-04/ C------------------------- DATA D10 /-.185185185185185E-02/, D1(1) /-.347222222222222E-02/, * D1(2) / .264550264550265E-02/, D1(3) /-.990226337448560E-03/, * D1(4) / .205761316872428E-03/ C------------------------- DATA D20 / .413359788359788E-02/, D2(1) /-.268132716049383E-02/, * D2(2) / .771604938271605E-03/ C------------------------- DATA D30 / .649434156378601E-03/, D3(1) / .229472093621399E-03/, * D3(2) /-.469189494395256E-03/ C------------------------- DATA D40 /-.861888290916712E-03/, D4(1) / .784039221720067E-03/ C------------------------- DATA D50 /-.336798553366358E-03/, D5(1) /-.697281375836586E-04/ C------------------------- DATA D60 / .531307936463992E-03/, D6(1) /-.592166437353694E-03/ C------------------------- DATA D70 / .344367606892378E-03/ C------------------------- DATA D80 /-.652623918595309E-03/ C------------------------- C C ****** E IS A MACHINE DEPENDENT CONSTANT. E IS THE SMALLEST C FLOATING POINT NUMBER FOR WHICH 1.0 + E .GT. 1.0 . C E = SPMPAR(1) C C------------------------- IF (A .LT. 0.0 .OR. X .LT. 0.0) GO TO 400 IF (A .EQ. 0.0 .AND. X .EQ. 0.0) GO TO 400 IF (A*X .EQ. 0.0) GO TO 331 C IOP = IND + 1 IF (IOP .NE. 1 .AND. IOP .NE. 2) IOP = 3 ACC = AMAX1(ACC0(IOP),E) C C SELECT THE APPROPRIATE ALGORITHM C IF (A .GE. 1.0) GO TO 10 IF (A .EQ. 0.5) GO TO 320 IF (X .LT. 1.1) GO TO 110 R = RCOMP(A,X) IF (R .EQ. 0.0) GO TO 310 GO TO 170 C 10 IF (A .GE. BIG(IOP)) GO TO 20 IF (A .GT. X .OR. X .GE. X0(IOP)) GO TO 30 TWOA = A + A M = INT(TWOA) IF (TWOA .NE. FLOAT(M)) GO TO 30 I = M/2 IF (A .EQ. FLOAT(I)) GO TO 140 GO TO 150 C 20 L = X/A IF (L .EQ. 0.0) GO TO 300 S = 0.5 + (0.5 - L) Z = RLOG(L) IF (Z .GE. 700.0/A) GO TO 330 Y = A*Z RTA = SQRT(A) IF (ABS(S) .LE. E0(IOP)/RTA) GO TO 250 IF (ABS(S) .LE. 0.4) GO TO 200 C 30 R = RCOMP(A,X) IF (R .EQ. 0.0) GO TO 331 IF (X .LE. AMAX1(A,ALOG10)) GO TO 50 IF (X .LT. X0(IOP)) GO TO 170 GO TO 80 C C TAYLOR SERIES FOR P/R C 50 APN = A + 1.0 T = X/APN WK(1) = T DO 51 N = 2,20 APN = APN + 1.0 T = T*(X/APN) IF (T .LE. 1.E-3) GO TO 60 WK(N) = T 51 CONTINUE N = 20 C 60 SUM = T TOL = 0.5*ACC 61 APN = APN + 1.0 T = T*(X/APN) SUM = SUM + T IF (T .GT. TOL) GO TO 61 C MAX = N - 1 DO 70 M = 1,MAX N = N - 1 SUM = SUM + WK(N) 70 CONTINUE ANS = (R/A)*(1.0 + SUM) QANS = 0.5 + (0.5 - ANS) RETURN C C ASYMPTOTIC EXPANSION C 80 AMN = A - 1.0 T = AMN/X WK(1) = T DO 81 N = 2,20 AMN = AMN - 1.0 T = T*(AMN/X) IF (ABS(T) .LE. 1.E-3) GO TO 90 WK(N) = T 81 CONTINUE N = 20 C 90 SUM = T 91 IF (ABS(T) .LT. ACC) GO TO 100 AMN = AMN - 1.0 T = T*(AMN/X) SUM = SUM + T GO TO 91 C 100 MAX = N - 1 DO 101 M = 1,MAX N = N - 1 SUM = SUM + WK(N) 101 CONTINUE QANS = (R/X)*(1.0 + SUM) ANS = 0.5 + (0.5 - QANS) RETURN C C TAYLOR SERIES FOR P(A,X)/X**A C 110 L = 3.0 C = X SUM = X/(A + 3.0) TOL = 3.0*ACC/(A + 1.0) 111 L = L + 1.0 C = -C*(X/L) T = C/(A + L) SUM = SUM + T IF (ABS(T) .GT. TOL) GO TO 111 J = A*X*((SUM/6.0 - 0.5/(A + 2.0))*X + 1.0/(A + 1.0)) C Z = A*ALOG(X) H = GAM1(A) G = 1.0 + H IF (X .LT. 0.25) GO TO 120 IF (A .LT. X/2.59) GO TO 135 GO TO 130 120 IF (Z .GT. -.13394) GO TO 135 C 130 W = EXP(Z) ANS = W*G*(0.5 + (0.5 - J)) QANS = 0.5 + (0.5 - ANS) RETURN C 135 L = REXP(Z) W = 0.5 + (0.5 + L) QANS = (W*J - L)*G - H IF (QANS .LT. 0.0) GO TO 310 ANS = 0.5 + (0.5 - QANS) RETURN C C FINITE SUMS FOR Q WHEN A .GE. 1 C AND 2*A IS AN INTEGER C 140 SUM = EXP(-X) T = SUM N = 1 C = 0.0 GO TO 160 C 150 RTX = SQRT(X) SUM = ERFC1(0,RTX) T = EXP(-X)/(RTPI*RTX) N = 0 C = -0.5 C 160 IF (N .EQ. I) GO TO 161 N = N + 1 C = C + 1.0 T = (X*T)/C SUM = SUM + T GO TO 160 161 QANS = SUM ANS = 0.5 + (0.5 - QANS) RETURN C C CONTINUED FRACTION EXPANSION C 170 TOL = AMAX1(8.0*E,4.0*ACC) A2NM1 = 1.0 A2N = 1.0 B2NM1 = X B2N = X + (1.0 - A) C = 1.0 180 A2NM1 = X*A2N + C*A2NM1 B2NM1 = X*B2N + C*B2NM1 C = C + 1.0 T = C - A A2N = A2NM1 + T*A2N B2N = B2NM1 + T*B2N C A2NM1 = A2NM1/B2N B2NM1 = B2NM1/B2N A2N = A2N/B2N B2N = 1.0 IF (ABS(A2N - A2NM1/B2NM1) .GE. TOL*A2N) GO TO 180 C QANS = R*A2N ANS = 0.5 + (0.5 - QANS) RETURN C 200 IF (ABS(S) .LE. 2.0*E .AND. A*E*E .GT. 3.28E-3) GO TO 400 C = EXP(-Y) W = 0.5*ERFC1(1,SQRT(Y)) U = 1.0/A Z = SQRT(Z + Z) IF (L .LT. 1.0) Z = -Z IF (IOP - 2) 210,220,230 C 210 IF (ABS(S) .LE. 1.E-3) GO TO 260 C C USING THE MINIMAX APPROXIMATIONS C C0 = (((A0(1)*Z + A0(2))*Z + A0(3))*Z + A0(4)) / ((((((B0(1)*Z + * B0(2))*Z + B0(3))*Z + B0(4))*Z + B0(5))*Z + B0(6))*Z + 1.0) C1 = (((A1(1)*Z + A1(2))*Z + A1(3))*Z + A1(4)) / * ((((B1(1)*Z + B1(2))*Z + B1(3))*Z + B1(4))*Z + 1.0) C2 = (A2(1)*Z + A2(2))/(((((B2(1)*Z + B2(2))*Z + B2(3))*Z + * B2(4))*Z + B2(5))*Z + 1.0) C3 = (A3(1)*Z + A3(2))/(((((B3(1)*Z + B3(2))*Z + B3(3))*Z + * B3(4))*Z + B3(5))*Z + 1.0) C4 = (A4(1)*Z + A4(2))/((((B4(1)*Z + B4(2))*Z + B4(3))*Z + * B4(4))*Z + 1.0) C5 = (A5(1)*Z + A5(2))/(((B5(1)*Z + B5(2))*Z + B5(3))*Z + 1.0) C6 = (A6(1)*Z + A6(2))/((B6(1)*Z + B6(2))*Z + 1.0) C7 = (A7(1)*Z + A7(2))/((B7(1)*Z + B7(2))*Z + 1.0) C8 = A8(1)*Z + A8(2) T = (((((((C8*U + C7)*U + C6)*U + C5)*U + C4)*U + C3)*U + * C2)*U + C1)*U + C0 GO TO 240 C C TEMME EXPANSION C 220 C0 = (((((D0(6) * Z + D0(5)) * Z + D0(4)) * Z + D0(3)) * Z * + D0(2)) * Z + D0(1)) * Z + D00 C1 = (((D1(4) * Z + D1(3)) * Z + D1(2)) * Z + D1(1)) * Z * + D10 C2 = D2(1) * Z + D20 T = (C2*U + C1)*U + C0 GO TO 240 C 230 T = ((D0(3) * Z + D0(2)) * Z + D0(1)) * Z + D00 C 240 IF (L .LT. 1.0) GO TO 241 QANS = C*(W + RT2PIN*T/RTA) ANS = 0.5 + (0.5 - QANS) RETURN 241 ANS = C*(W - RT2PIN*T/RTA) QANS = 0.5 + (0.5 - ANS) RETURN C C TEMME EXPANSION FOR L = 1 C 250 IF (A*E*E .GT. 3.28E-3) GO TO 400 C = 0.5 + (0.5 - Y) W = (0.5 - SQRT(Y)*(0.5 + (0.5 - Y/3.0))/RTPI)/C U = 1.0/A Z = SQRT(Z + Z) IF (L .LT. 1.0) Z = -Z IF (IOP - 2) 260,270,280 C 260 C0 = ((D0(3) * Z + D0(2)) * Z + D0(1)) * Z + D00 C1 = ((D1(3) * Z + D1(2)) * Z + D1(1)) * Z + D10 C2 = (D2(2) * Z + D2(1)) * Z + D20 C3 = (D3(2) * Z + D3(1)) * Z + D30 C4 = D4(1) * Z + D40 C5 = D5(1) * Z + D50 C6 = D6(1) * Z + D60 T = (((((((D80*U + D70)*U + C6)*U + C5)*U + C4)*U + C3)*U * + C2)*U + C1)*U + C0 GO TO 240 C 270 C0 = (D0(2) * Z + D0(1)) * Z + D00 C1 = D1(1) * Z + D10 T = (D20*U + C1)*U + C0 GO TO 240 C 280 T = D0(1) * Z + D00 GO TO 240 C C SPECIAL CASES C 300 ANS = 0.0 QANS = 1.0 RETURN C 310 ANS = 1.0 QANS = 0.0 RETURN C 320 IF (X .GE. 0.25) GO TO 321 ANS = ERF(SQRT(X)) QANS = 0.5 + (0.5 - ANS) RETURN 321 QANS = ERFC1(0,SQRT(X)) ANS = 0.5 + (0.5 - QANS) RETURN C 330 IF (ABS(S) .LE. 2.0*E) GO TO 400 331 IF (X .LE. A) GO TO 300 GO TO 310 C C ERROR RETURN C 400 ANS = 2.0 RETURN END REAL FUNCTION RCOMP (A, X) C----------------------------------------------------------------------- C EVALUATION OF EXP(-X)*X**A/GAMMA(A) C----------------------------------------------------------------------- C RT2PIN = 1/SQRT(2*PI) C------------------------ DATA RT2PIN/.398942280401433/ C------------------------ RCOMP = 0.0 IF (X .EQ. 0.0) RETURN IF (A .GE. 20.0) GO TO 20 C T = A*ALOG(X) - X IF (T .LT. EXPARG(1)) RETURN IF (A .GE. 1.0) GO TO 10 RCOMP = (A*EXP(T))*(1.0 + GAM1(A)) RETURN 10 RCOMP = EXP(T)/GAMMA(A) RETURN C 20 U = X/A IF (U .EQ. 0.0) RETURN T = (1.0/A)**2 T1 = (((0.75*T - 1.0)*T + 3.5)*T - 105.0)/(A*1260.0) T1 = T1 - A*RLOG(U) IF (T1 .GE. EXPARG(1)) RCOMP = RT2PIN*SQRT(A)*EXP(T1) RETURN END DOUBLE PRECISION FUNCTION DRCOMP (A, X) C----------------------------------------------------------------------- C EVALUATION OF EXP(-X)*X**A/GAMMA(A) C----------------------------------------------------------------------- DOUBLE PRECISION A, X, C, T, W DOUBLE PRECISION DGAMMA, DGAM1, DPDEL, DRLOG, DXPARG C-------------------------- C C = 1/SQRT(2*PI) C-------------------------- DATA C /.398942280401432677939946059934D0/ C-------------------------- DRCOMP = 0.D0 IF (X .EQ. 0.D0) RETURN IF (A .GT. 20.D0) GO TO 20 C T = A*DLOG(X) - X IF (T .LT. DXPARG(1)) RETURN IF (A .GE. 1.D0) GO TO 10 DRCOMP = (A*DEXP(T))*(1.D0 + DGAM1(A)) RETURN 10 DRCOMP = DEXP(T)/DGAMMA(A) RETURN C 20 T = X/A IF (T .EQ. 0.D0) RETURN W = -(DPDEL(A) + A*DRLOG(T)) IF (W .GE. DXPARG(1)) DRCOMP = C * DSQRT(A) * DEXP(W) RETURN END SUBROUTINE GAMINV (A, X, X0, P, Q, IERR) C----------------------------------------------------------------------- C C INVERSE INCOMPLETE GAMMA RATIO FUNCTION C C GIVEN POSITIVE A, AND NONEGATIVE P AND Q WHERE P + Q = 1. C THEN X IS COMPUTED WHERE P(A,X) = P AND Q(A,X) = Q. SCHRODER C ITERATION IS EMPLOYED. THE ROUTINE ATTEMPTS TO COMPUTE X C TO 10 SIGNIFICANT DIGITS IF THIS IS POSSIBLE FOR THE C PARTICULAR COMPUTER ARITHMETIC BEING USED. C C ------------ C C X IS A VARIABLE. IF P = 0 THEN X IS ASSIGNED THE VALUE 0, C AND IF Q = 0 THEN X IS SET TO THE LARGEST FLOATING POINT C NUMBER AVAILABLE. OTHERWISE, GAMINV ATTEMPTS TO OBTAIN C A SOLUTION FOR P(A,X) = P AND Q(A,X) = Q. IF THE ROUTINE C IS SUCCESSFUL THEN THE SOLUTION IS STORED IN X. C C X0 IS AN OPTIONAL INITIAL APPROXIMATION FOR X. IF THE USER C DOES NOT WISH TO SUPPLY AN INITIAL APPROXIMATION, THEN SET C X0 .LE. 0. C C IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS. C WHEN THE ROUTINE TERMINATES, IERR HAS ONE OF THE FOLLOWING C VALUES ... C C IERR = 0 THE SOLUTION WAS OBTAINED. ITERATION WAS C NOT USED. C IERR.GT.0 THE SOLUTION WAS OBTAINED. IERR ITERATIONS C WERE PERFORMED. C IERR = -2 (INPUT ERROR) A .LE. 0 C IERR = -3 NO SOLUTION WAS OBTAINED. THE RATIO Q/A C IS TOO LARGE. C IERR = -4 (INPUT ERROR) P OR Q IS NEGATIVE, OR C P + Q .NE. 1. C IERR = -6 20 ITERATIONS WERE PERFORMED. THE MOST C RECENT VALUE OBTAINED FOR X IS GIVEN. C THIS CANNOT OCCUR IF X0 .LE. 0. C IERR = -7 ITERATION FAILED. NO VALUE IS GIVEN FOR X. C THIS MAY OCCUR WHEN X IS APPROXIMATELY 0. C IERR = -8 A VALUE FOR X HAS BEEN OBTAINED, BUT THE C ROUTINE IS NOT CERTAIN OF ITS ACCURACY. C ITERATION CANNOT BE PERFORMED IN THIS C CASE. IF X0 .LE. 0, THIS CAN OCCUR ONLY C WHEN P OR Q IS APPROXIMATELY 0. IF X0 IS C POSITIVE THEN THIS CAN OCCUR WHEN A IS C EXCEEDINGLY CLOSE TO X AND A IS EXTREMELY C LARGE (SAY A .GE. 1.E20). C C----------------------------------------------------------------------- C WRITTEN BY ALFRED H. MORRIS, JR. C NAVAL SURFACE WARFARE CENTER C DAHLGREN, VIRGINIA C REVISED ... JANUARY 1992 C------------------------ REAL LN10, BMIN(2), EMIN(2) C------------------------ C LN10 = LN(10) C C = EULER CONSTANT C------------------------ DATA LN10 /2.302585/ DATA C /.577215664901533/ C------------------------ DATA BMIN(1) /1.E-28/, BMIN(2) /1.E-13/ DATA EMIN(1) /2.E-03/, EMIN(2) /6.E-03/ C------------------------ DATA TOL /1.E-5/ C------------------------ C C ****** E AND XMIN ARE MACHINE DEPENDENT CONSTANTS. E IS THE C SMALLEST NUMBER FOR WHICH 1.0 + E .GT. 1.0, AND XMIN C IS THE SMALLEST POSITIVE NUMBER. C E = SPMPAR(1) XMIN = SPMPAR(2) C C------------------------ X = 0.0 IF (A .LE. 0.0) GO TO 500 IF (P .LT. 0.0 .OR. Q .LT. 0.0) GO TO 520 T = ((P + Q) - 0.5) - 0.5 IF (ABS(T) .GT. 5.0*AMAX1(E,1.E-15)) GO TO 520 C IERR = 0 XMIN = XMIN/E IF ((P/E) .LE. XMIN) GO TO 400 IF ((Q/E) .LE. XMIN) GO TO 560 IF (A .EQ. 1.0) GO TO 410 C E2 = E + E AMAX = 0.4E-10/(E*E) EPS = AMAX1(100.0*E,1.E-10) IOP = 1 IF (E .GT. 1.E-10) IOP = 2 XN = X0 IF (X0 .GT. 0.0) GO TO 100 C C SELECTION OF THE INITIAL APPROXIMATION XN OF X C WHEN A .LT. 1 C IF (A .GT. 1.0) GO TO 50 G = GAMMA(A + 1.0) QG = Q*G IF (QG .EQ. 0.0) GO TO 560 B = QG/A IF (QG .GT. 0.6*A) GO TO 20 IF (A .GE. 0.30 .OR. B .LT. 0.35) GO TO 10 T = EXP(-(B + C)) U = T*EXP(T) XN = T*EXP(U) GO TO 100 C 10 IF (B .GE. 0.45) GO TO 20 IF (B .EQ. 0.0) GO TO 560 Y = -ALOG(B) S = 0.5 + (0.5 - A) Z = ALOG(Y) T = Y - S*Z IF (B .LT. 0.15) GO TO 11 XN = Y - S*ALOG(T) - ALOG(1.0 + S/(T + 1.0)) GO TO 200 11 IF (B .LE. 1.E-2) GO TO 12 U = ((T + 2.0*(3.0 - A))*T + (2.0 - A)*(3.0 - A))/ * ((T + (5.0 - A))*T + 2.0) XN = Y - S*ALOG(T) - ALOG(U) GO TO 200 12 C1 = -S*Z C2 = -S*(1.0 + C1) C3 = S*((0.5*C1 + (2.0 - A))*C1 + (2.5 - 1.5*A)) C4 = -S*(((C1/3.0 + (2.5 - 1.5*A))*C1 + ((A - 6.0)*A + 7.0))*C1 * + ((11.0*A - 46.0)*A + 47.0)/6.0) C5 = -S*((((-C1/4.0 + (11.0*A - 17.0)/6.0)*C1 * + ((-3.0*A + 13.0)*A - 13.0))*C1 * + 0.5*(((2.0*A - 25.0)*A + 72.0)*A - 61.0))*C1 * + (((25.0*A - 195.0)*A + 477.0)*A - 379.0)/12.0) XN = ((((C5/Y + C4)/Y + C3)/Y + C2)/Y + C1) + Y IF (A .GT. 1.0) GO TO 200 IF (B .GT. BMIN(IOP)) GO TO 200 X = XN RETURN C 20 IF (B*Q .GT. 1.E-8) GO TO 21 XN = EXP(-(Q/A + C)) GO TO 30 21 IF (P .LE. 0.9) GO TO 22 XN = EXP((ALNREL(-Q) + GAMLN1(A))/A) GO TO 30 22 XN = EXP(ALOG(P*G)/A) C 30 IF (XN .EQ. 0.0) GO TO 510 T = 0.5 + (0.5 - XN/(A + 1.0)) XN = XN/T GO TO 100 C C SELECTION OF THE INITIAL APPROXIMATION XN OF X C WHEN A .GT. 1 C 50 T = P - 0.5 IF (Q .LT. 0.5) T = 0.5 - Q CALL PNI (P, Q, T, S, IER) C RTA = SQRT(A) S2 = S*S XN = (((12.0*S2 - 243.0)*S2 - 923.0)*S2 + 1472.0)/204120.0 XN = (XN/A + S*((9.0*S2 + 256.0)*S2 - 433.0)/(38880.0*RTA)) * - ((3.0*S2 + 7.0)*S2 - 16.0)/810.0 XN = A + S*RTA + (S2 - 1.0)/3.0 + S*(S2 - 7.0)/(36.0*RTA) * + XN/A XN = AMAX1(XN, 0.0) C AMIN = 20.0 IF (E .LT. 1.E-8) AMIN = 250.0 IF (A .LT. AMIN) GO TO 60 X = XN D = 0.5 + (0.5 - X/A) IF (ABS(D) .LE. 1.E-1) RETURN C 60 IF (P .LE. 0.5) GO TO 70 IF (XN .LT. 3.0*A) GO TO 200 W = ALOG(Q) Y = -(W + GAMLN(A)) D = AMAX1(2.0, A*(A - 1.0)) IF (Y .LT. LN10*D) GO TO 61 S = 1.0 - A Z = ALOG(Y) GO TO 12 61 T = A - 1.0 XN = Y + T*ALOG(XN) - ALNREL(-T/(XN + 1.0)) XN = Y + T*ALOG(XN) - ALNREL(-T/(XN + 1.0)) GO TO 200 C 70 AP1 = A + 1.0 IF (XN .GT. 0.70*AP1) GO TO 101 W = ALOG(P) + GAMLN(AP1) IF (XN .GT. 0.15*AP1) GO TO 80 AP2 = A + 2.0 AP3 = A + 3.0 X = EXP((W + X)/A) X = EXP((W + X - ALOG(1.0 + (X/AP1)*(1.0 + X/AP2)))/A) X = EXP((W + X - ALOG(1.0 + (X/AP1)*(1.0 + X/AP2)))/A) X = EXP((W + X - ALOG(1.0 + (X/AP1)*(1.0 + (X/AP2)*(1.0 * + X/AP3))))/A) XN = X IF (XN .GT. 1.E-2*AP1) GO TO 80 IF (XN .LE. EMIN(IOP)*AP1) RETURN GO TO 101 C 80 APN = AP1 T = XN/APN SUM = 1.0 + T 81 APN = APN + 1.0 T = T*(XN/APN) SUM = SUM + T IF (T .GT. 1.E-4) GO TO 81 T = W - ALOG(SUM) XN = EXP((XN + T)/A) XN = XN*(1.0 - (A*ALOG(XN) - XN - T)/(A - XN)) GO TO 101 C C SCHRODER ITERATION USING P C 100 IF (P .GT. 0.5) GO TO 200 101 IF (P .LE. XMIN) GO TO 550 AM1 = (A - 0.5) - 0.5 102 IF (A .LE. AMAX) GO TO 110 D = 0.5 + (0.5 - XN/A) IF (ABS(D) .LE. E2) GO TO 550 C 110 IF (IERR .GE. 20) GO TO 530 IERR = IERR + 1 CALL GRATIO (A, XN, PN, QN, 0) IF (PN .EQ. 0.0 .OR. QN .EQ. 0.0) GO TO 550 R = RCOMP(A,XN) IF (R .LT. XMIN) GO TO 550 T = (PN - P)/R W = 0.5*(AM1 - XN) IF (ABS(T) .LE. 0.1 .AND. ABS(W*T) .LE. 0.1) GO TO 120 X = XN*(1.0 - T) IF (X .LE. 0.0) GO TO 540 D = ABS(T) GO TO 121 C 120 H = T*(1.0 + W*T) X = XN*(1.0 - H) IF (X .LE. 0.0) GO TO 540 IF (ABS(W) .GE. 1.0 .AND. ABS(W)*T*T .LE. EPS) RETURN D = ABS(H) 121 XN = X IF (D .GT. TOL) GO TO 102 IF (D .LE. EPS) RETURN IF (ABS(P - PN) .LE. TOL*P) RETURN GO TO 102 C C SCHRODER ITERATION USING Q C 200 IF (Q .LE. XMIN) GO TO 550 AM1 = (A - 0.5) - 0.5 201 IF (A .LE. AMAX) GO TO 210 D = 0.5 + (0.5 - XN/A) IF (ABS(D) .LE. E2) GO TO 550 C 210 IF (IERR .GE. 20) GO TO 530 IERR = IERR + 1 CALL GRATIO (A, XN, PN, QN, 0) IF (PN .EQ. 0.0 .OR. QN .EQ. 0.0) GO TO 550 R = RCOMP(A,XN) IF (R .LT. XMIN) GO TO 550 T = (Q - QN)/R W = 0.5*(AM1 - XN) IF (ABS(T) .LE. 0.1 .AND. ABS(W*T) .LE. 0.1) GO TO 220 X = XN*(1.0 - T) IF (X .LE. 0.0) GO TO 540 D = ABS(T) GO TO 221 C 220 H = T*(1.0 + W*T) X = XN*(1.0 - H) IF (X .LE. 0.0) GO TO 540 IF (ABS(W) .GE. 1.0 .AND. ABS(W)*T*T .LE. EPS) RETURN D = ABS(H) 221 XN = X IF (D .GT. TOL) GO TO 201 IF (D .LE. EPS) RETURN IF (ABS(Q - QN) .LE. TOL*Q) RETURN GO TO 201 C C SPECIAL CASES C 400 IERR = -8 RETURN C 410 IF (Q .LT. 0.9) GO TO 411 X = -ALNREL(-P) RETURN 411 X = -ALOG(Q) RETURN C C ERROR RETURN C 500 IERR = -2 RETURN C 510 IERR = -3 RETURN C 520 IERR = -4 RETURN C 530 IERR = -6 RETURN C 540 IERR = -7 RETURN C 550 X = XN IERR = -8 RETURN C 560 X = SPMPAR(3) IERR = -8 RETURN END SUBROUTINE DGRAT (A, X, ANS, QANS, IERR) C----------------------------------------------------------------------- C C EVALUATION OF THE INCOMPLETE GAMMA RATIO FUNCTIONS C P(A,X) AND Q(A,X) C C----------------------------------------------------------------------- C WRITTEN BY ALFRED H. MORRIS, JR. C NAVAL SURFACE WARFARE CENTER C DAHLGREN, VIRGINIA C REVISED ... JAN 1992 C------------------------- DOUBLE PRECISION A, X, ANS, QANS DOUBLE PRECISION AMN, ALOG10, APN, A2N, A2NM1, BIG, B2N, * B2NM1, C, E, G, H, J, L, R, RTA, RTPI, RTX, S, * SUM, T, TOL, TWOA, U, X0, Y, Z, WK(20) DOUBLE PRECISION DPMPAR, DRLOG, DREXP DOUBLE PRECISION DERF, DERFC1, DGAM1, DRCOMP C------------------------- C ALOG10 = LN(10) C RTPI = DSQRT(PI) C------------------------- DATA ALOG10 /2.30258509299404568401799145468D0/ DATA RTPI /1.77245385090551602729816748334D0/ C------------------------- C C ****** E IS A MACHINE DEPENDENT CONSTANT. E IS THE SMALLEST C FLOATING POINT NUMBER FOR WHICH 1.0 + E .GT. 1.0 . C E = DPMPAR(1) C C------------------------- IF (A .LT. 0.D0 .OR. X .LT. 0.D0) GO TO 400 IF (A .EQ. 0.D0 .AND. X .EQ. 0.D0) GO TO 410 IERR = 0 IF (A*X .EQ. 0.D0) GO TO 331 C E = DMAX1(E,1.D-30) BIG = 30.D0 IF (E .LT. 1.D-17) BIG = 50.D0 X0 = 45.D0 IF (E .LT. 1.D-17) X0 = 68.D0 C C SELECT THE APPROPRIATE ALGORITHM C IF (A .GE. 1.D0) GO TO 10 IF (A .EQ. 0.5D0) GO TO 320 IF (X .LE. 2.D0) GO TO 110 R = DRCOMP(A,X) IF (R .EQ. 0.D0) GO TO 310 GO TO 170 C 10 IF (A .GE. BIG) GO TO 20 IF (A .GT. X .OR. X .GE. X0) GO TO 30 TWOA = A + A M = TWOA L = M IF (TWOA .NE. L) GO TO 30 I = M/2 L = I IF (A .EQ. L) GO TO 140 GO TO 150 C 20 L = X/A IF (L .EQ. 0.D0) GO TO 300 S = 0.5D0 + (0.5D0 - L) Z = DRLOG(L) IF (Z .GE. 700.D0/A) GO TO 330 Y = A*Z RTA = DSQRT(A) IF (DABS(S) .LE. 0.4D0) GO TO 200 C 30 R = DRCOMP(A,X) IF (R .EQ. 0.D0) GO TO 331 IF (X .LE. DMAX1(A,ALOG10)) GO TO 50 IF (X .LT. X0) GO TO 170 GO TO 80 C C TAYLOR SERIES FOR P/R C 50 APN = A + 1.D0 T = X/APN WK(1) = T DO 51 N = 2,20 APN = APN + 1.D0 T = T*(X/APN) IF (T .LT. 1.D-3) GO TO 60 WK(N) = T 51 CONTINUE N = 20 C 60 SUM = T TOL = 0.5D0*E 61 APN = APN + 1.D0 T = T*(X/APN) SUM = SUM + T IF (T .GT. TOL) GO TO 61 C MAX = N - 1 DO 70 M = 1,MAX N = N - 1 SUM = SUM + WK(N) 70 CONTINUE ANS = (R/A)*(1.D0 + SUM) QANS = 0.5D0 + (0.5D0 - ANS) RETURN C C ASYMPTOTIC EXPANSION C 80 AMN = A - 1.D0 T = AMN/X WK(1) = T DO 81 N = 2,20 AMN = AMN - 1.D0 T = T*(AMN/X) IF (DABS(T) .LE. 1.D-3) GO TO 90 WK(N) = T 81 CONTINUE N = 20 C 90 SUM = T 91 IF (DABS(T) .LT. E) GO TO 100 AMN = AMN - 1.D0 T = T*(AMN/X) SUM = SUM + T GO TO 91 C 100 MAX = N - 1 DO 101 M = 1,MAX N = N - 1 SUM = SUM + WK(N) 101 CONTINUE QANS = (R/X)*(1.D0 + SUM) ANS = 0.5D0 + (0.5D0 - QANS) RETURN C C TAYLOR SERIES FOR P(A,X)/X**A C 110 L = 3.D0 C = X SUM = X/(A + 3.D0) TOL = 3.D0*E/(A + 1.D0) 120 L = L + 1.D0 C = -C*(X/L) T = C/(A + L) SUM = SUM + T IF (DABS(T) .GT. TOL) GO TO 120 J = A*X*((SUM/6.D0 - 0.5D0/(A + 2.D0))*X + 1.D0/(A + 1.D0)) C Z = A*DLOG(X) U = DEXP(Z) H = DGAM1(A) G = 1.D0 + H ANS = U*G*(0.5D0 + (0.5D0 - J)) QANS = 0.5D0 + (0.5D0 - ANS) IF (ANS .LE. 0.9D0) RETURN C L = DREXP(Z) QANS = (U*J - L)*G - H IF (QANS .LE. 0.D0) GO TO 310 ANS = 0.5D0 + (0.5D0 - QANS) RETURN C C FINITE SUMS FOR Q WHEN A .GE. 1 C AND 2*A IS AN INTEGER C 140 SUM = DEXP(-X) T = SUM N = 1 C = 0.D0 GO TO 160 C 150 RTX = DSQRT(X) SUM = DERFC1(0,RTX) T = DEXP(-X)/(RTPI*RTX) N = 0 C = -0.5D0 C 160 IF (N .EQ. I) GO TO 161 N = N + 1 C = C + 1.D0 T = (X*T)/C SUM = SUM + T GO TO 160 161 QANS = SUM ANS = 0.5D0 + (0.5D0 - QANS) RETURN C C CONTINUED FRACTION EXPANSION C 170 TOL = 8.D0*E A2NM1 = 1.D0 A2N = 1.D0 B2NM1 = X B2N = X + (1.D0 - A) C = 1.D0 180 A2NM1 = X*A2N + C*A2NM1 B2NM1 = X*B2N + C*B2NM1 C = C + 1.D0 T = C - A A2N = A2NM1 + T*A2N B2N = B2NM1 + T*B2N C A2NM1 = A2NM1/B2N B2NM1 = B2NM1/B2N A2N = A2N/B2N B2N = 1.D0 IF (DABS(A2N - A2NM1/B2NM1) .GE. TOL*A2N) GO TO 180 C QANS = R*A2N ANS = 0.5D0 + (0.5D0 - QANS) RETURN C C MINIMAX APPROXIMATIONS C 200 IF (DABS(S) .LE. 2.D0*E .AND. A*E*E .GT. 3.28D-3) GO TO 420 IF (E .LT. 1.D-17) GO TO 210 CALL DGR17 (A, Y, L, Z, RTA, ANS, QANS) RETURN 210 CALL DGR29 (A, Y, L, Z, RTA, ANS, QANS) RETURN C C SPECIAL CASES C 300 ANS = 0.D0 QANS = 1.D0 RETURN C 310 ANS = 1.D0 QANS = 0.D0 RETURN C 320 IF (X .GE. 0.25D0) GO TO 321 ANS = DERF(DSQRT(X)) QANS = 0.5D0 + (0.5D0 - ANS) RETURN 321 QANS = DERFC1(0,DSQRT(X)) ANS = 0.5D0 + (0.5D0 - QANS) RETURN C 330 IF (DABS(S) .LE. 2.D0*E) GO TO 420 331 IF (X .LE. A) GO TO 300 GO TO 310 C C ERROR RETURN C 400 IERR = 1 ANS = 2.D0 RETURN C 410 IERR = 2 ANS = 2.D0 RETURN C 420 IERR = 3 ANS = 2.D0 RETURN END SUBROUTINE DGR29 (A, Y, L, Z, RTA, ANS, QANS) C----------------------------------------------------------------------- C C ALGORITHM USING MINIMAX APPROXIMATIONS C C----------------------------------------------------------------------- DOUBLE PRECISION A, Y, L, Z, RTA, ANS, QANS DOUBLE PRECISION A0(7), A1(7), A2(7), A3(7), A4(7), A5(7), A6(4), * A7(5), A8(5), A9(5), A10(4), A11(4), A12(4), * A13(3), A14(3), A15(2), A16(2), A17(1), A18(1) DOUBLE PRECISION B0(9), B1(9), B2(8), B3(8), B4(8), B5(7), B6(9), * B7(7), B8(7), B9(6), B10(6), B11(5), B12(4), * B13(4), B14(2), B15(2), B16(1) DOUBLE PRECISION C0, C1, C2, C3, C4, C5, C6, C7, C8, C9, C10, * C11, C12, C13, C14, C15, C16 DOUBLE PRECISION D0(7), E, RT2PIN, T, U, W DOUBLE PRECISION DERFC1 C--------------------------- C RT2PIN = 1/DSQRT(2*PI) C--------------------------- DATA RT2PIN /.398942280401432677939946059934D0/ C--------------------------- DATA D0(1) /-.333333333333333333333333333333D+00/, * D0(2) / .833333333333333333333333333333D-01/, * D0(3) /-.148148148148148148148148148148D-01/, * D0(4) / .115740740740740740740740740741D-02/, * D0(5) / .352733686067019400352733686067D-03/, * D0(6) /-.178755144032921810699588477366D-03/, * D0(7) / .391926317852243778169704095630D-04/ C--------------------------- DATA A0(1) /-.234443848930188413698825870D-08/, * A0(2) /-.408902435641223939887180303D-07/, * A0(3) /-.327874000161065050049103731D-06/, * A0(4) /-.145717031728609218851588740D-05/, * A0(5) /-.372722892959910688597417881D-05/, * A0(6) /-.490033281596113358850307112D-05/, * A0(7) /-.218544851067999216147364227D-05/ DATA B0(1) /-.129786815987713980865910767D-09/, * B0(2) /.319268409139858531586963150D-08/, * B0(3) /.597739416777031660496708557D-04/, * B0(4) /.131659965062389880196860991D-02/, * B0(5) /.138263099503103838517015533D-01/, * B0(6) /.866750030433403450681521877D-01/, * B0(7) /.349373447613102956696810725D+00/, * B0(8) /.902581259032419042347458484D+00/, * B0(9) /.139388806936391316154237713D+01/ C--------------------------- DATA A1(1) /-.162671127226300802902860047D-05/, * A1(2) /-.359791514993122440319624428D-04/, * A1(3) /-.334816794629374699945489443D-03/, * A1(4) /-.167787748352827199882047653D-02/, * A1(5) /-.462960105006279850867332060D-02/, * A1(6) /-.627269388216833251971110268D-02/, * A1(7) /-.185185185185185185185185200D-02/ DATA B1(1) /.361538770500640888027927000D-09/, * B1(2) /.974094440943696092434381137D-05/, * B1(3) /.275463718595762102271929980D-03/, * B1(4) /.356903970692700621824901511D-02/, * B1(5) /.276755209895072417713430394D-01/, * B1(6) /.140741499324744724262767201D+00/, * B1(7) /.482173396010404307346794795D+00/, * B1(8) /.109307843990990308990473663D+01/, * B1(9) /.151225469637089956064399494D+01/ C--------------------------- DATA A2(1) /.100841467329617467204527243D-06/, * A2(2) /.261809837060522545971782889D-05/, * A2(3) /.351658023234640143803014403D-04/, * A2(4) /.287368655528567495658887760D-03/, * A2(5) /.138385867950361368914038461D-02/, * A2(6) /.365985331203490698463644329D-02/, * A2(7) /.413359788359788359788359644D-02/ DATA B2(1) /.144996224602847932479320241D-04/, * B2(2) /.378705615967233119938297206D-03/, * B2(3) /.457258679387716305283282667D-02/, * B2(4) /.333036784835643463383606186D-01/, * B2(5) /.160392471625881407829191009D+00/, * B2(6) /.524238095721639512312120765D+00/, * B2(7) /.114320896084982707537755002D+01/, * B2(8) /.153405837991415136438992306D+01/ C--------------------------- DATA A3(1) /.352304123782956092061364635D-06/, * A3(2) /.695396758348887902366951353D-05/, * A3(3) /.620467118988901865955998784D-04/, * A3(4) /.331552280167649130371474456D-03/, * A3(5) /.987931909328964685388525477D-03/, * A3(6) /.141844584435355290321010006D-02/, * A3(7) /.649434156378600823045102236D-03/ DATA B3(1) /.656342109234806261144233394D-04/, * B3(2) /.130398975231883219976260776D-02/, * B3(3) /.126418031281256648240652355D-01/, * B3(4) /.760733201461716525855765749D-01/, * B3(5) /.308149284260387354956024487D+00/, * B3(6) /.856743428738899911100227393D+00/, * B3(7) /.159678625605457556492814589D+01/, * B3(8) /.183078413578083710405050462D+01/ C--------------------------- DATA A4(1) /-.260879135093022176005540138D-07/, * A4(2) /-.470448694272734954500324169D-06/, * A4(3) /-.487392507564453824976295590D-05/, * A4(4) /-.337525643163070607393381432D-04/, * A4(5) /-.173138093150706317400323103D-03/, * A4(6) /-.619343030286408407629007048D-03/, * A4(7) /-.861888290916711698604710684D-03/ DATA B4(1) /.561738585657138771286755470D-04/, * B4(2) /.104553622856827932853059322D-02/, * B4(3) /.990129468337836044520381371D-02/, * B4(4) /.590964360473404599955095091D-01/, * B4(5) /.241580582651643837306299024D+00/, * B4(6) /.686949677014349678482109368D+00/, * B4(7) /.133507902144433100426436242D+01/, * B4(8) /.162826466816694512158165085D+01/ C--------------------------- DATA A5(1) /-.116166342948098688243985652D-07/, * A5(2) / .506465072067030007394288471D-08/, * A5(3) /-.556701576804390213081214801D-05/, * A5(4) /-.332229941748769925615918550D-04/, * A5(5) /-.171902547619915856635305717D-03/, * A5(6) /-.548868487607991087508092013D-03/, * A5(7) /-.336798553366358151161633777D-03/ DATA B5(1) /.106576106868815233442641444D-03/, * B5(2) /.280714123386276098548285440D-02/, * B5(3) /.254669201041872409738119341D-01/, * B5(4) /.136071713023783507468096673D+00/, * B5(5) /.462890328922621047510807887D+00/, * B5(6) /.103913867517817784825064299D+01/, * B5(7) /.142263185288429590449288300D+01/ C--------------------------- DATA A6(1) /.118384620224413424936260301D-04/, * A6(2) /.694345283181981060040314140D-05/, * A6(3) /.209213745619758030399432459D-03/, * A6(4) /.531307936463992224884286210D-03/ DATA B6(1) /-.633002360430352916354621750D-05/, * B6(2) /-.248639208901374031411609873D-04/, * B6(3) /.151734058829700925162000373D-03/, * B6(4) /.477475914272399601740818883D-02/, * B6(5) /.384410125775084107229541456D-01/, * B6(6) /.184699876959596092801262547D+00/, * B6(7) /.571784440733980642101712125D+00/, * B6(8) /.118432122801495778365352945D+01/, * B6(9) /.150831585220968267709550582D+01/ C--------------------------- DATA A7(1) /.972342656522493967167788395D-05/, * A7(2) /.462793722775687016808279009D-04/, * A7(3) /.208913588225005764102252127D-03/, * A7(4) /.605983804794748515383615779D-03/, * A7(5) /.344367606892381545765962366D-03/ DATA B7(1) /.215964480325937088444595990D-03/, * B7(2) /.621296161441756044580440529D-02/, * B7(3) /.497403555098433701440032746D-01/, * B7(4) /.230812334251394761909158355D+00/, * B7(5) /.682159830165959997577293001D+00/, * B7(6) /.133753662990343866552766613D+01/, * B7(7) /.160951809815647533045690195D+01/ C--------------------------- DATA A8(1) /-.231069438570167401077137510D-05/, * A8(2) /-.192877995065652524742879002D-04/, * A8(3) /-.282551884312564905942488077D-04/, * A8(4) /-.353272052089782073130912603D-03/, * A8(5) /-.652623918595320914510590273D-03/ DATA B8(1) /.156052480203446255774109882D-02/, * B8(2) /.189231675289329563916597032D-01/, * B8(3) /.110127834209242088316741250D+00/, * B8(4) /.407929996207245634766606879D+00/, * B8(5) /.101702505946784412105505734D+01/, * B8(6) /.172269407630659768618234623D+01/, * B8(7) /.182765408802230546887514255D+01/ C--------------------------- DATA A9(1) /-.203007139532451428594124139D-04/, * A9(2) /-.120148495117517992204095691D-03/, * A9(3) /-.377126645910917006921076652D-03/, * A9(4) /-.109151697941931403194363814D-02/, * A9(5) /-.596761290192642722092337263D-03/ DATA B9(1) /.108808775028021530146610124D-01/, * B9(2) /.803149717787956717154553908D-01/, * B9(3) /.335555306170768573903990019D+00/, * B9(4) /.881575022436158946373557744D+00/, * B9(5) /.156222230858412078350692234D+01/, * B9(6) /.170833470935668756293234818D+01/ C--------------------------- DATA A10(1)/ .475862254251166503473724173D-04/, * A10(2)/-.352503880413640910997936559D-04/, * A10(3)/ .580375987713106460207815603D-03/, * A10(4)/ .133244544950730832649306319D-02/ DATA B10(1) /.161103572271541189817119144D-01/, * B10(2) /.114651544043625219459951640D+00/, * B10(3) /.448280675300097555552484502D+00/, * B10(4) /.110810715319704031415255670D+01/, * B10(5) /.183146436130501918547134176D+01/, * B10(6) /.187235769169449339141968881D+01/ C--------------------------- DATA A11(1) /.121185049262809526794966703D-03/, * A11(2) /.717725173388339108430635016D-05/, * A11(3) /.246371734409638623215800502D-02/, * A11(4) /.157972766214718575927904484D-02/ DATA B11(1) /.794610889405176143379963912D-02/, * B11(2) /.131627017265860324219513170D+00/, * B11(3) /.505939635317477779328000706D+00/, * B11(4) /.116082103318559904744144217D+01/, * B11(5) /.145670749780693850410866175D+01/ C--------------------------- DATA A12(1)/-.246294151509758620837749269D-03/, * A12(2)/ .650624975008642297405944869D-03/, * A12(3)/-.214376520139497301154749750D-03/, * A12(4)/-.407251199495291398243480255D-02/ DATA B12(1) /.168390445944818504703640731D+00/, * B12(2) /.653453590771198550320727688D+00/, * B12(3) /.140298208333879535577602171D+01/, * B12(4) /.162497775209192630951344224D+01/ C--------------------------- DATA A13(1)/-.159520095187034545391135461D-02/, * A13(2)/-.109727312966041723997078734D-01/, * A13(3)/-.594758070915055362667114240D-02/ DATA B13(1) /.207815761771742289849225339D+00/, * B13(2) /.790935125477975506817064616D+00/, * B13(3) /.158706682625067673596619095D+01/, * B13(4) /.175409273929961597148916309D+01/ C--------------------------- DATA A14(1)/ .245543970647383469794050102D-02/, * A14(2)/-.119636668153843644820445054D-01/, * A14(3)/ .175722793448246103440764372D-01/ DATA B14(1) /.676925518749829493412063599D+00/, * B14(2) /.100158659226079685399214158D+01/ C--------------------------- DATA A15(1) /.588261033368548917447688791D-01/, * A15(2) /.400765463491067514929787780D-01/ DATA B15(1) /.124266359850901469771032599D+01/, * B15(2) /.149189509890654955611528542D+01/ C--------------------------- DATA A16(1)/ .119522261141925960204472459D+00/, * A16(2)/-.100326700196947262548667584D+00/ DATA B16(1) /.536462039767059451769400255D+00/ C--------------------------- DATA A17(1)/-.259949826752497731336860753D+00/ C--------------------------- DATA A18(1) /.724036968309299822373280436D+00/ C--------------------------- E = DEXP(-Y) W = 0.5D0*DERFC1(1,DSQRT(Y)) U = 1.D0/A Z = DSQRT(Z + Z) IF (L .LT. 1.D0) Z = -Z C T = ((((((A0(1)*Z + A0(2))*Z + A0(3))*Z + A0(4))*Z + A0(5))*Z + * A0(6))*Z + A0(7)) / (((((((((B0(1)*Z + B0(2))*Z + * B0(3))*Z + B0(4))*Z + B0(5))*Z + B0(6))*Z + B0(7))*Z + * B0(8))*Z + B0(9))*Z + 1.D0) C0 = ((((((T*Z + D0(7))*Z + D0(6))*Z + D0(5))*Z + D0(4))*Z + * D0(3))*Z + D0(2))*Z + D0(1) C1 = ((((((A1(1)*Z + A1(2))*Z + A1(3))*Z + A1(4))*Z + A1(5))*Z + * A1(6))*Z + A1(7)) / (((((((((B1(1)*Z + B1(2))*Z + * B1(3))*Z + B1(4))*Z + B1(5))*Z + B1(6))*Z + B1(7))*Z + * B1(8))*Z + B1(9))*Z + 1.D0) C2 = ((((((A2(1)*Z + A2(2))*Z + A2(3))*Z + A2(4))*Z + A2(5))*Z + * A2(6))*Z + A2(7)) / ((((((((B2(1)*Z + B2(2))*Z + * B2(3))*Z + B2(4))*Z + B2(5))*Z + B2(6))*Z + B2(7))*Z + * B2(8))*Z + 1.D0) C3 = ((((((A3(1)*Z + A3(2))*Z + A3(3))*Z + A3(4))*Z + A3(5))*Z + * A3(6))*Z + A3(7)) / ((((((((B3(1)*Z + B3(2))*Z + * B3(3))*Z + B3(4))*Z + B3(5))*Z + B3(6))*Z + B3(7))*Z + * B3(8))*Z + 1.D0) C4 = ((((((A4(1)*Z + A4(2))*Z + A4(3))*Z + A4(4))*Z + A4(5))*Z + * A4(6))*Z + A4(7)) / ((((((((B4(1)*Z + B4(2))*Z + * B4(3))*Z + B4(4))*Z + B4(5))*Z + B4(6))*Z + B4(7))*Z + * B4(8))*Z + 1.D0) C5 = ((((((A5(1)*Z + A5(2))*Z + A5(3))*Z + A5(4))*Z + A5(5))*Z + * A5(6))*Z + A5(7)) / (((((((B5(1)*Z + B5(2))*Z + * B5(3))*Z + B5(4))*Z + B5(5))*Z + B5(6))*Z + B5(7))*Z + * 1.D0) C6 = (((A6(1)*Z + A6(2))*Z + A6(3))*Z + A6(4)) /(((((((((B6(1)*Z + * B6(2))*Z + B6(3))*Z + B6(4))*Z + B6(5))*Z + B6(6))*Z + * B6(7))*Z + B6(8))*Z + B6(9))*Z + 1.D0) C7 = ((((A7(1)*Z + A7(2))*Z + A7(3))*Z + A7(4))*Z + A7(5)) / * (((((((B7(1)*Z + B7(2))*Z + B7(3))*Z + B7(4))*Z + B7(5))*Z + * B7(6))*Z + B7(7))*Z + 1.D0) C8 = ((((A8(1)*Z + A8(2))*Z + A8(3))*Z + A8(4))*Z + A8(5)) / * (((((((B8(1)*Z + B8(2))*Z + B8(3))*Z + B8(4))*Z + B8(5))*Z + * B8(6))*Z + B8(7))*Z + 1.D0) C9 = ((((A9(1)*Z + A9(2))*Z + A9(3))*Z + A9(4))*Z + A9(5)) / * ((((((B9(1)*Z + B9(2))*Z + B9(3))*Z + B9(4))*Z + B9(5))*Z + * B9(6))*Z + 1.D0) C10 = (((A10(1)*Z + A10(2))*Z + A10(3))*Z + A10(4)) / * ((((((B10(1)*Z + B10(2))*Z + B10(3))*Z + B10(4))*Z + * B10(5))*Z + B10(6))*Z + 1.D0) C11 = (((A11(1)*Z + A11(2))*Z + A11(3))*Z + A11(4)) / * (((((B11(1)*Z + B11(2))*Z + B11(3))*Z + B11(4))*Z + * B11(5))*Z + 1.D0) C12 = (((A12(1)*Z + A12(2))*Z + A12(3))*Z + A12(4)) / * ((((B12(1)*Z + B12(2))*Z + B12(3))*Z + B12(4))*Z + 1.D0) C13 = ((A13(1)*Z + A13(2))*Z + A13(3)) / ((((B13(1)*Z + * B13(2))*Z + B13(3))*Z + B13(4))*Z + 1.D0) C14 = ((A14(1)*Z + A14(2))*Z + A14(3)) / ((B14(1)*Z + * B14(2))*Z + 1.D0) C15 = (A15(1)*Z + A15(2)) / ((B15(1)*Z + B15(2))*Z + 1.D0) C16 = (A16(1)*Z + A16(2)) / (B16(1)*Z + 1.D0) C T = (A18(1)*U + A17(1))*U + C16 T = (((((((((((((((T*U + C15)*U + C14)*U + C13)*U + C12)*U + * C11)*U + C10)*U + C9)*U + C8)*U + C7)*U + C6)*U + * C5)*U + C4)*U + C3)*U + C2)*U + C1)*U + C0 C IF (L .LT. 1.D0) GO TO 10 QANS = E*(W + RT2PIN*T/RTA) ANS = 0.5D0 + (0.5D0 - QANS) RETURN 10 ANS = E*(W - RT2PIN*T/RTA) QANS = 0.5D0 + (0.5D0 - ANS) RETURN END SUBROUTINE DGR17 (A, Y, L, Z, RTA, ANS, QANS) C----------------------------------------------------------------------- C C ALGORITHM USING MINIMAX APPROXIMATIONS C FOR C0,...,C10 C C----------------------------------------------------------------------- DOUBLE PRECISION A, Y, L, Z, RTA, ANS, QANS DOUBLE PRECISION E, RT2PIN, T, U, W DOUBLE PRECISION C0, C1, C2, C3, C4, C5, C6, C7, C8, C9, C10 DOUBLE PRECISION A0(5), A1(4), A2(4), A3(4), A4(3), A5(2), * A6(2), A7(2), A8(2), A9(3), A10(2) DOUBLE PRECISION B0(6), B1(6), B2(5), B3(4), B4(4), B5(4), * B6(3), B7(3), B8(2) DOUBLE PRECISION DERFC1 C------------------------ C RT2PIN = 1/DSQRT(2*PI) C------------------------ DATA RT2PIN /.398942280401432678D0/ C------------------------ DATA * A0(1) /-.73324404807556026D-03/, A0(2) /-.11758531313175796D-01/, * A0(3) /-.76816029947195974D-01/, A0(4) /-.24232172943558393D+00/, * A0(5) /-.33333333333333333D+00/ DATA * B0(1) /.10555647473018528D-06/, B0(2) /.73121701584237188D-03/, * B0(3) /.13250270182342259D-01/, B0(4) /.10288837674434487D+00/, * B0(5) /.43024494247383254D+00/, B0(6) /.97696518830675185D+00/ C------------------------ DATA * A1(1) /-.16746784557475121D-03/, A1(2) /-.16090334014223031D-02/, * A1(3) /-.52949366601406939D-02/, A1(4) /-.18518518518518417D-02/ DATA * B1(1) /.12328086517283227D-05/, B1(2) /.98671953445602142D-03/, * B1(3) /.15954049115266936D-01/, B1(4) /.11439610256504704D+00/, * B1(5) /.45195109694529839D+00/, B1(6) /.98426579647613593D+00/ C------------------------ DATA * A2(1) /.12049855113125238D-04/, A2(2) /.13743853858711134D-03/, * A2(3) /.15067356806896441D-02/, A2(4) /.41335978835983393D-02/ DATA * B2(1) /.15927093345670077D-02/, B2(2) /.22316881460606523D-01/, * B2(3) /.14009848931638062D+00/, B2(4) /.50379606871703058D+00/, * B2(5) /.10131761625405203D+01/ C------------------------ DATA * A3(1) /.46318872971699924D-05/, A3(2) /.13012396979747783D-04/, * A3(3) /.81804333975935872D-03/, A3(4) /.64943415637082551D-03/ DATA * B3(1) /.12414068921653593D-01/, B3(2) /.10044290377295469D+00/, * B3(3) /.42226789458984594D+00/, B3(4) /.90628317147366376D+00/ C------------------------ DATA * A4(1) /-.37567394580525597D-05/, A4(2) /-.82794205648271314D-04/, * A4(3) /-.86188829773520181D-03/ DATA * B4(1) /.31290397554562032D-01/, B4(2) /.16988291247058802D+00/, * B4(3) /.57225859400072754D+00/, B4(4) /.10057375981227881D+01/ C------------------------ DATA * A5(1) /-.43263341886764011D-03/, A5(2) /-.33679854644784478D-03/ DATA * B5(1) /.22714615451529335D-01/, B5(2) /.17081504060220639D+00/, * B5(3) /.60019022026983067D+00/, B5(4) /.10775200414676195D+01/ C------------------------ DATA * A6(1) /-.12962670089753501D-03/, A6(2) /.53130115408837152D-03/ DATA * B6(1) /.65929776650152292D-01/, B6(2) /.45957439582639129D+00/, * B6(3) /.87058903334443855D+00/ C------------------------ DATA * A7(1) /.47861364421780889D-03/, A7(2) /.34438428473168988D-03/ DATA * B7(1) /.27176241899664174D+00/, B7(2) /.78991370162247144D+00/, * B7(3) /.12396875725833093D+01/ C------------------------ DATA * A8(1) /.27086391808339115D-03/, A8(2) /-.65256615574219131D-03/ DATA * B8(1) /.44207055629598579D+00/, B8(2) /.87002402612484571D+00/ C------------------------ DATA * A9(1) / .84725086921921823D-03/, A9(2) /-.14838721516118744D-03/, * A9(3) /-.60335050249571475D-03/ C------------------------ DATA * A10(1)/-.19144384985654775D-02/, A10(2) /.13324454494800656D-02/ C------------------------ E = DEXP(-Y) W = 0.5D0*DERFC1(1,DSQRT(Y)) U = 1.D0/A Z = DSQRT(Z + Z) IF (L .LT. 1.D0) Z = -Z C C0 = ((((A0(1)*Z + A0(2))*Z + A0(3))*Z + A0(4))*Z + A0(5)) / * ((((((B0(1)*Z + B0(2))*Z + B0(3))*Z + B0(4))*Z + B0(5))*Z + * B0(6))*Z + 1.D0) C1 = (((A1(1)*Z + A1(2))*Z + A1(3))*Z + A1(4)) / ((((((B1(1)*Z + * B1(2))*Z + B1(3))*Z + B1(4))*Z + B1(5))*Z + B1(6))*Z + * 1.D0) C2 = (((A2(1)*Z + A2(2))*Z + A2(3))*Z + A2(4)) / (((((B2(1)*Z + * B2(2))*Z + B2(3))*Z + B2(4))*Z + B2(5))*Z + 1.D0) C3 = (((A3(1)*Z + A3(2))*Z + A3(3))*Z + A3(4)) / ((((B3(1)*Z + * B3(2))*Z + B3(3))*Z + B3(4))*Z + 1.D0) C4 = ((A4(1)*Z + A4(2))*Z + A4(3)) / ((((B4(1)*Z + B4(2))*Z + * B4(3))*Z + B4(4))*Z + 1.D0) C5 = (A5(1)*Z + A5(2)) / ((((B5(1)*Z + B5(2))*Z + B5(3))*Z + * B5(4))*Z + 1.D0) C6 = (A6(1)*Z + A6(2))/(((B6(1)*Z + B6(2))*Z + B6(3))*Z + 1.D0) C7 = (A7(1)*Z + A7(2))/(((B7(1)*Z + B7(2))*Z + B7(3))*Z + 1.D0) C8 = (A8(1)*Z + A8(2))/((B8(1)*Z + B8(2))*Z + 1.D0) C9 = (A9(1)*Z + A9(2))*Z + A9(3) C10 = A10(1)*Z + A10(2) C T = (((((((((C10*U + C9)*U + C8)*U + C7)*U + C6)*U + C5)*U + * C4)*U + C3)*U + C2)*U + C1)*U + C0 C IF (L .LT. 1.D0) GO TO 10 QANS = E*(W + RT2PIN*T/RTA) ANS = 0.5D0 + (0.5D0 - QANS) RETURN 10 ANS = E*(W - RT2PIN*T/RTA) QANS = 0.5D0 + (0.5D0 - ANS) RETURN END SUBROUTINE DGINV (A, X, P, Q, IERR) C----------------------------------------------------------------------- C C DOUBLE PRECISION C INVERSE INCOMPLETE GAMMA RATIO FUNCTION C C GIVEN POSITIVE A, AND NONEGATIVE P AND Q WHERE P + Q = 1. C THEN X IS COMPUTED WHERE P(A,X) = P AND Q(A,X) = Q. SCHRODER C ITERATION IS EMPLOYED. C C ------------ C C X IS A VARIABLE. IF P = 0 THEN X IS ASSIGNED THE VALUE 0, C AND IF Q = 0 THEN X IS SET TO THE LARGEST FLOATING POINT C NUMBER AVAILABLE. OTHERWISE, DGINV ATTEMPTS TO OBTAIN C A SOLUTION FOR P(A,X) = P AND Q(A,X) = Q. IF THE ROUTINE C IS SUCCESSFUL THEN THE SOLUTION IS STORED IN X. C C IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS. C WHEN THE ROUTINE TERMINATES, IERR HAS ONE OF THE FOLLOWING C VALUES ... C C IERR = 0 THE SOLUTION WAS OBTAINED. ITERATION WAS C NOT USED. C IERR.GT.0 THE SOLUTION WAS OBTAINED. IERR ITERATIONS C WERE PERFORMED. C IERR = -2 (INPUT ERROR) A .LE. 0 C IERR = -3 NO SOLUTION WAS OBTAINED. THE RATIO Q/A C IS TOO LARGE. C IERR = -4 (INPUT ERROR) P OR Q IS NEGATIVE, OR C P + Q .NE. 1. C IERR = -6 10 ITERATIONS WERE PERFORMED. THE MOST C RECENT VALUE OBTAINED FOR X IS GIVEN. C (THIS SETTING SHOULD NEVER OCCUR.) C IERR = -7 ITERATION FAILED. NO VALUE IS GIVEN FOR X. C THIS MAY OCCUR WHEN X IS APPROXIMATELY 0. C IERR = -8 A VALUE FOR X HAS BEEN OBTAINED, BUT THE C ROUTINE IS NOT CERTAIN OF ITS ACCURACY. C ITERATION CANNOT BE PERFORMED IN THIS C CASE. THIS SETTING CAN OCCUR ONLY WHEN C P OR Q IS APPROXIMATELY 0. C C----------------------------------------------------------------------- C WRITTEN BY ALFRED H. MORRIS, JR. C NAVAL SURFACE WARFARE CENTER C DAHLGREN, VIRGINIA C WRITTEN ... JANUARY 1992 C------------------------ DOUBLE PRECISION A, X, P, Q REAL P0, Q0, X0 DOUBLE PRECISION AM1, APN, AP1, AP2, AP3, B, C, C1, C2, C3, C4, * C5, D, E, EPS, G, H, LN10, PN, QG, QN, R, RTA, * S, SUM, S2, T, TOL, U, W, XMIN, XN, Y, Z, AMIN DOUBLE PRECISION DPMPAR, DLNREL, DGAMMA, DGAMLN, DGMLN1, DRCOMP C------------------------ C LN10 = LN(10) C C = EULER CONSTANT C------------------------ DATA LN10 /2.302585D0/ DATA C /.577215664901533D0/ C------------------------ DATA TOL /1.D-10/ C------------------------ C C ****** E AND XMIN ARE MACHINE DEPENDENT CONSTANTS. E IS THE C SMALLEST NUMBER FOR WHICH 1.0 + E .GT. 1.0, AND XMIN C IS THE SMALLEST POSITIVE NUMBER. C E = DPMPAR(1) XMIN = DPMPAR(2) C C------------------------ X = 0.D0 IF (A .LE. 0.D0) GO TO 500 IF (P .LT. 0.D0 .OR. Q .LT. 0.D0) GO TO 520 T = ((P + Q) - 0.5D0) - 0.5D0 IF (DABS(T) .GT. 5.D0*DMAX1(E,1.D-30)) GO TO 520 C IERR = 0 XMIN = XMIN/E IF ((P/E) .LE. XMIN) GO TO 400 IF ((Q/E) .LE. XMIN) GO TO 560 IF (A .EQ. 1.D0) GO TO 410 C E = DMAX1(E,1.D-30) EPS = 1.D3*E AMIN = 5.D3 IF (E .LT. 1.D-17) AMIN = 2.D6 IF (A .GE. AMIN) GO TO 50 C C GET AN INITIAL APPROXIMATION USING THE SINGLE C PRECISION ARITHMETIC (IF THIS IS POSSIBLE) C P0 = P Q0 = Q IF (P0 .EQ. 0.0 .OR. Q0 .EQ. 0.0) GO TO 10 CALL GAMINV (SNGL(A), X0, 0.0, P0, Q0, IER) IF (IER .LT. 0.0 .AND. IER .NE. -8) GO TO 10 IERR = MAX0(IER,0) IF (X0 .GT. 1.E34) GO TO 10 XN = X0 GO TO 100 C 10 IF (A .GT. 1.D0) GO TO 50 XN = 0.D0 C C SELECTION OF THE INITIAL APPROXIMATION XN OF X C WHEN A .LT. 1 C G = DGAMMA(A + 1.D0) QG = Q*G IF (QG .EQ. 0.D0) GO TO 560 B = QG/A IF (QG .GT. 0.6D0*A) GO TO 30 IF (A .GE. 0.30D0 .OR. B .LT. 0.35D0) GO TO 20 T = DEXP(-(B + C)) U = T*DEXP(T) XN = T*DEXP(U) GO TO 100 C 20 IF (B .GE. 0.45D0) GO TO 30 IF (B .EQ. 0.D0) GO TO 560 Y = -DLOG(B) S = 0.5D0 + (0.5D0 - A) Z = DLOG(Y) T = Y - S*Z IF (B .LT. 0.15D0) GO TO 21 XN = Y - S*DLOG(T) - DLOG(1.D0 + S/(T + 1.D0)) GO TO 200 21 IF (B .LE. 1.D-2) GO TO 22 U = ((T + 2.D0*(3.D0 - A))*T + (2.D0 - A)*(3.D0 - A))/ * ((T + (5.D0 - A))*T + 2.D0) XN = Y - S*DLOG(T) - DLOG(U) GO TO 200 22 C1 = -S*Z C2 = -S*(1.D0 + C1) C3 = S*((0.5D0*C1 + (2.D0 - A))*C1 + (2.5D0 - 1.5D0*A)) C4 = -S*(((C1/3.D0 + (2.5D0 - 1.5D0*A))*C1 + ((A - 6.D0)*A * + 7.D0))*C1 + ((11.D0*A - 46.D0)*A + 47.D0)/6.D0) C5 = -S*((((-C1/4.D0 + (11.D0*A - 17.D0)/6.D0)*C1 * + ((-3.D0*A + 13.D0)*A - 13.D0))*C1 * + 0.5D0*(((2.D0*A - 25.D0)*A + 72.D0)*A - 61.D0))*C1 * + (((25.D0*A - 195.D0)*A + 477.D0)*A - 379.D0)/12.D0) XN = ((((C5/Y + C4)/Y + C3)/Y + C2)/Y + C1) + Y GO TO 200 C 30 IF (B*Q .GT. 1.D-8) GO TO 31 XN = DEXP(-(Q/A + C)) GO TO 40 31 IF (P .LE. 0.9D0) GO TO 32 XN = DEXP((DLNREL(-Q) + DGMLN1(A))/A) GO TO 40 32 XN = DEXP(DLOG(P*G)/A) C 40 IF (XN .EQ. 0.D0) GO TO 510 T = 0.5D0 + (0.5D0 - XN/(A + 1.D0)) XN = XN/T GO TO 100 C C SELECTION OF THE INITIAL APPROXIMATION XN OF X C WHEN A .GT. 1 C 50 T = P - 0.5D0 IF (Q .LT. 0.5D0) T = 0.5D0 - Q CALL DPNI (P, Q, T, S, IER) C RTA = DSQRT(A) S2 = S*S XN = (((12.D0*S2 - 243.D0)*S2 - 923.D0)*S2 + 1472.D0)/204120.D0 * - S*(((3753.D0*S2 + 4353.D0)*S2 - 289517.D0)*S2 - 289717.D0) * /(146966400.D0*RTA) XN = (XN/A + S*((9.D0*S2 + 256.D0)*S2 - 433.D0)/(38880.D0*RTA)) * - ((3.D0*S2 + 7.D0)*S2 - 16.D0)/810.D0 XN = A + S*RTA + (S2 - 1.D0)/3.D0 + S*(S2 - 7.D0)/(36.D0*RTA) * + XN/A XN = DMAX1(XN, 0.D0) C IF (A .LT. AMIN) GO TO 60 X = XN D = 0.5D0 + (0.5D0 - X/A) IF (DABS(D) .GT. 1.D-1) GO TO 60 IF (DABS(D) .GT. 1.D-3) GO TO 100 RETURN C 60 IF (P .LE. 0.5D0) GO TO 70 IF (XN .LT. 3.D0*A) GO TO 200 W = DLOG(Q) Y = -(W + DGAMLN(A)) D = DMAX1(2.D0, A*(A - 1.D0)) IF (Y .LT. LN10*D) GO TO 61 S = 1.D0 - A Z = DLOG(Y) GO TO 22 61 T = A - 1.D0 XN = Y + T*DLOG(XN) - DLNREL(-T/(XN + 1.D0)) XN = Y + T*DLOG(XN) - DLNREL(-T/(XN + 1.D0)) GO TO 200 C 70 AP1 = A + 1.D0 IF (XN .GT. 0.7D0*AP1) GO TO 101 W = DLOG(P) + DGAMLN(AP1) IF (XN .GT. 0.15D0*AP1) GO TO 80 AP2 = A + 2.D0 AP3 = A + 3.D0 X = DEXP((W + X)/A) X = DEXP((W + X - DLOG(1.0 + (X/AP1)*(1.D0 + X/AP2)))/A) X = DEXP((W + X - DLOG(1.0 + (X/AP1)*(1.D0 + X/AP2)))/A) X = DEXP((W + X - DLOG(1.0 + (X/AP1)*(1.D0 + (X/AP2)*(1.D0 * + X/AP3))))/A) XN = X IF (XN .LE. 1.D-2*AP1) GO TO 101 C 80 APN = AP1 T = XN/APN SUM = 1.D0 + T 81 APN = APN + 1.D0 T = T*(XN/APN) SUM = SUM + T IF (T .GT. 1.D-4) GO TO 81 T = W - DLOG(SUM) XN = DEXP((XN + T)/A) XN = XN*(1.D0 - (A*DLOG(XN) - XN - T)/(A - XN)) GO TO 101 C C SCHRODER ITERATION USING P C 100 IF (P .GT. 0.5D0) GO TO 200 101 IF (P .LE. XMIN) GO TO 550 AM1 = (A - 0.5D0) - 0.5D0 C 110 IF (IERR .GE. 10) GO TO 530 IERR = IERR + 1 CALL DGRAT (A, XN, PN, QN, IND) IF (PN .EQ. 0.D0 .OR. QN .EQ. 0.D0) GO TO 550 R = DRCOMP(A,XN) IF (R .LT. XMIN) GO TO 550 T = (PN - P)/R W = 0.5D0*(AM1 - XN) IF (DABS(T) .LE. 0.1D0 .AND. DABS(W*T) .LE. 0.1D0) GO TO 120 X = XN*(1.D0 - T) IF (X .LE. 0.D0) GO TO 540 D = DABS(T) GO TO 121 C 120 H = T*(1.D0 + W*T) X = XN*(1.D0 - H) IF (X .LE. 0.D0) GO TO 540 IF (DABS(W) .GE. 1.D0 .AND. DABS(W)*T*T .LE. EPS) RETURN D = DABS(H) 121 XN = X IF (D .GT. TOL) GO TO 110 IF (D .LE. EPS) RETURN IF (DABS(P - PN) .LE. TOL*P) RETURN GO TO 110 C C SCHRODER ITERATION USING Q C 200 IF (Q .LE. XMIN) GO TO 550 AM1 = (A - 0.5D0) - 0.5D0 C 210 IF (IERR .GE. 10) GO TO 530 IERR = IERR + 1 CALL DGRAT (A, XN, PN, QN, IND) IF (PN .EQ. 0.D0 .OR. QN .EQ. 0.D0) GO TO 550 R = DRCOMP(A,XN) IF (R .LT. XMIN) GO TO 550 T = (Q - QN)/R W = 0.5D0*(AM1 - XN) IF (DABS(T) .LE. 0.1D0 .AND. DABS(W*T) .LE. 0.1D0) GO TO 220 X = XN*(1.D0 - T) IF (X .LE. 0.D0) GO TO 540 D = DABS(T) GO TO 221 C 220 H = T*(1.D0 + W*T) X = XN*(1.D0 - H) IF (X .LE. 0.D0) GO TO 540 IF (DABS(W) .GE. 1.D0 .AND. DABS(W)*T*T .LE. EPS) RETURN D = DABS(H) 221 XN = X IF (D .GT. TOL) GO TO 210 IF (D .LE. EPS) RETURN IF (DABS(Q - QN) .LE. TOL*Q) RETURN GO TO 210 C C SPECIAL CASES C 400 IERR = -8 RETURN C 410 IF (Q .LT. 0.9D0) GO TO 411 X = -DLNREL(-P) RETURN 411 X = -DLOG(Q) RETURN C C ERROR RETURN C 500 IERR = -2 RETURN C 510 IERR = -3 RETURN C 520 IERR = -4 RETURN C 530 IERR = -6 RETURN C 540 IERR = -7 RETURN C 550 X = XN IERR = -8 RETURN C 560 X = DPMPAR(3) IERR = -8 RETURN END SUBROUTINE BRATIO (A, B, X, Y, W, W1, IERR) C----------------------------------------------------------------------- C C EVALUATION OF THE INCOMPLETE BETA FUNCTION IX(A,B) C C -------------------- C C IT IS ASSUMED THAT A AND B ARE NONNEGATIVE, AND THAT X .LE. 1 C AND Y = 1 - X. BRATIO ASSIGNS W AND W1 THE VALUES C C W = IX(A,B) C W1 = 1 - IX(A,B) C C IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS. C IF NO INPUT ERRORS ARE DETECTED THEN IERR IS SET TO 0 AND C W AND W1 ARE COMPUTED. OTHERWISE, IF AN ERROR IS DETECTED, C THEN W AND W1 ARE ASSIGNED THE VALUE 0 AND IERR IS SET TO C ONE OF THE FOLLOWING VALUES ... C C IERR = 1 IF A OR B IS NEGATIVE C IERR = 2 IF A = B = 0 C IERR = 3 IF X .LT. 0 OR X .GT. 1 C IERR = 4 IF Y .LT. 0 OR Y .GT. 1 C IERR = 5 IF X + Y .NE. 1 C IERR = 6 IF X = A = 0 C IERR = 7 IF Y = B = 0 C C-------------------- C WRITTEN BY ALFRED H. MORRIS, JR. C NAVAL SURFACE WARFARE CENTER C DAHLGREN, VIRGINIA C REVISED ... NOV 1991 C----------------------------------------------------------------------- REAL LAMBDA C----------------------------------------------------------------------- C C ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE SMALLEST C FLOATING POINT NUMBER FOR WHICH 1.0 + EPS .GT. 1.0 C EPS = SPMPAR(1) C C----------------------------------------------------------------------- W = 0.0 W1 = 0.0 IF (A .LT. 0.0 .OR. B .LT. 0.0) GO TO 300 IF (A .EQ. 0.0 .AND. B .EQ. 0.0) GO TO 310 IF (X .LT. 0.0 .OR. X .GT. 1.0) GO TO 320 IF (Y .LT. 0.0 .OR. Y .GT. 1.0) GO TO 330 Z = ((X + Y) - 0.5) - 0.5 IF (ABS(Z) .GT. 3.0*EPS) GO TO 340 C IERR = 0 IF (X .EQ. 0.0) GO TO 200 IF (Y .EQ. 0.0) GO TO 210 IF (A .EQ. 0.0) GO TO 211 IF (B .EQ. 0.0) GO TO 201 C EPS = AMAX1(EPS, 1.E-15) IF (AMAX1(A,B) .LT. 1.E-3*EPS) GO TO 230 C IND = 0 A0 = A B0 = B X0 = X Y0 = Y IF (AMIN1(A0, B0) .GT. 1.0) GO TO 30 C C PROCEDURE FOR A0 .LE. 1 OR B0 .LE. 1 C IF (X .LE. 0.5) GO TO 10 IND = 1 A0 = B B0 = A X0 = Y Y0 = X C 10 IF (B0 .LT. AMIN1(EPS,EPS*A0)) GO TO 80 IF (A0 .LT. AMIN1(EPS,EPS*B0) .AND. B0*X0 .LE. 1.0) GO TO 90 IF (AMAX1(A0, B0) .GT. 1.0) GO TO 20 IF (A0 .GE. AMIN1(0.2, B0)) GO TO 100 IF (X0**A0 .LE. 0.9) GO TO 100 IF (X0 .GE. 0.3) GO TO 110 N = 20 GO TO 130 C 20 IF (B0 .LE. 1.0) GO TO 100 IF (X0 .GE. 0.3) GO TO 110 IF (X0 .GE. 0.1) GO TO 21 IF ((X0*B0)**A0 .LE. 0.7) GO TO 100 21 IF (B0 .GT. 15.0) GO TO 131 N = 20 GO TO 130 C C PROCEDURE FOR A0 .GT. 1 AND B0 .GT. 1 C 30 IF (A .GT. B) GO TO 31 LAMBDA = A - (A + B)*X GO TO 32 31 LAMBDA = (A + B)*Y - B 32 IF (LAMBDA .GE. 0.0) GO TO 40 IND = 1 A0 = B B0 = A X0 = Y Y0 = X LAMBDA = ABS(LAMBDA) C 40 IF (B0 .LT. 40.0 .AND. B0*X0 .LE. 0.7) GO TO 100 IF (B0 .LT. 40.0) GO TO 140 IF (A0 .GT. B0) GO TO 50 IF (A0 .LE. 100.0) GO TO 120 IF (LAMBDA .GT. 0.03*A0) GO TO 120 GO TO 180 50 IF (B0 .LE. 100.0) GO TO 120 IF (LAMBDA .GT. 0.03*B0) GO TO 120 GO TO 180 C C EVALUATION OF THE APPROPRIATE ALGORITHM C 80 W = FPSER(A0, B0, X0, EPS) W1 = 0.5 + (0.5 - W) GO TO 220 C 90 W1 = APSER(A0, B0, X0, EPS) W = 0.5 + (0.5 - W1) GO TO 220 C 100 W = BPSER(A0, B0, X0, EPS) W1 = 0.5 + (0.5 - W) GO TO 220 C 110 W1 = BPSER(B0, A0, Y0, EPS) W = 0.5 + (0.5 - W1) GO TO 220 C 120 W = BFRAC(A0, B0, X0, Y0, LAMBDA, 15.0*EPS) W1 = 0.5 + (0.5 - W) GO TO 220 C 130 W1 = BUP(B0, A0, Y0, X0, N, EPS) B0 = B0 + N 131 CALL BGRAT(B0, A0, Y0, X0, W1, 15.0*EPS, IERR1) W = 0.5 + (0.5 - W1) GO TO 220 C 140 N = B0 B0 = B0 - N IF (B0 .NE. 0.0) GO TO 141 N = N - 1 B0 = 1.0 141 W = BUP(B0, A0, Y0, X0, N, EPS) IF (X0 .GT. 0.7) GO TO 150 W = W + BPSER(A0, B0, X0, EPS) W1 = 0.5 + (0.5 - W) GO TO 220 C 150 IF (A0 .GT. 15.0) GO TO 151 N = 20 W = W + BUP(A0, B0, X0, Y0, N, EPS) A0 = A0 + N 151 CALL BGRAT(A0, B0, X0, Y0, W, 15.0*EPS, IERR1) W1 = 0.5 + (0.5 - W) GO TO 220 C 180 W = BASYM(A0, B0, LAMBDA, 100.0*EPS) W1 = 0.5 + (0.5 - W) GO TO 220 C C TERMINATION OF THE PROCEDURE C 200 IF (A .EQ. 0.0) GO TO 350 201 W = 0.0 W1 = 1.0 RETURN C 210 IF (B .EQ. 0.0) GO TO 360 211 W = 1.0 W1 = 0.0 RETURN C 220 IF (IND .EQ. 0) RETURN T = W W = W1 W1 = T RETURN C C PROCEDURE FOR A AND B .LT. 1.E-3*EPS C 230 W = B/(A + B) W1 = A/(A + B) RETURN C C ERROR RETURN C 300 IERR = 1 RETURN 310 IERR = 2 RETURN 320 IERR = 3 RETURN 330 IERR = 4 RETURN 340 IERR = 5 RETURN 350 IERR = 6 RETURN 360 IERR = 7 RETURN END REAL FUNCTION FPSER (A, B, X, EPS) C----------------------------------------------------------------------- C C EVALUATION OF I (A,B) C X C C FOR B .LT. MIN(EPS,EPS*A) AND X .LE. 0.5. C C----------------------------------------------------------------------- C C SET FPSER = X**A C FPSER = 1.0 IF (A .LE. 1.E-3*EPS) GO TO 10 FPSER = 0.0 T = A*ALOG(X) IF (T .LT. EXPARG(1)) RETURN FPSER = EXP(T) C C NOTE THAT 1/B(A,B) = B C 10 FPSER = (B/A)*FPSER TOL = EPS/A AN = A + 1.0 T = X S = T/AN 20 AN = AN + 1.0 T = X*T C = T/AN S = S + C IF (ABS(C) .GT. TOL) GO TO 20 C FPSER = FPSER*(1.0 + A*S) RETURN END REAL FUNCTION APSER (A, B, X, EPS) C----------------------------------------------------------------------- C APSER YIELDS THE INCOMPLETE BETA RATIO I(SUB(1-X))(B,A) FOR C A .LE. MIN(EPS,EPS*B), B*X .LE. 1, AND X .LE. 0.5. USED WHEN C A IS VERY SMALL. USE ONLY IF ABOVE INEQUALITIES ARE SATISFIED. C----------------------------------------------------------------------- REAL J C-------------------- DATA G/.577215664901533/ C-------------------- BX = B*X T = X - BX IF (B*EPS .GT. 2.E-2) GO TO 10 C = ALOG(X) + PSI(B) + G + T GO TO 20 10 C = ALOG(BX) + G + T C 20 TOL = 5.0*EPS*ABS(C) J = 1.0 S = 0.0 30 J = J + 1.0 T = T*(X - BX/J) AJ = T/J S = S + AJ IF (ABS(AJ) .GT. TOL) GO TO 30 C APSER = -A*(C + S) RETURN END REAL FUNCTION BPSER(A, B, X, EPS) C----------------------------------------------------------------------- C POWER SERIES EXPANSION FOR EVALUATING IX(A,B) WHEN B .LE. 1 C OR B*X .LE. 0.7. EPS IS THE TOLERANCE USED. C----------------------------------------------------------------------- REAL N C BPSER = 0.0 IF (X .EQ. 0.0) RETURN C----------------------------------------------------------------------- C COMPUTE THE FACTOR X**A/(A*BETA(A,B)) C----------------------------------------------------------------------- A0 = AMIN1(A,B) IF (A0 .LT. 1.0) GO TO 10 Z = A*ALOG(X) - BETALN(A,B) BPSER = EXP(Z)/A GO TO 70 10 B0 = AMAX1(A,B) IF (B0 .GE. 8.0) GO TO 60 IF (B0 .GT. 1.0) GO TO 40 C C PROCEDURE FOR A0 .LT. 1 AND B0 .LE. 1 C BPSER = X**A IF (BPSER .EQ. 0.0) RETURN C APB = A + B IF (APB .GT. 1.0) GO TO 20 Z = 1.0 + GAM1(APB) GO TO 30 20 U = DBLE(A) + DBLE(B) - 1.D0 Z = (1.0 + GAM1(U))/APB C 30 C = (1.0 + GAM1(A))*(1.0 + GAM1(B))/Z BPSER = BPSER*C*(B/APB) GO TO 70 C C PROCEDURE FOR A0 .LT. 1 AND 1 .LT. B0 .LT. 8 C 40 U = GAMLN1(A0) M = B0 - 1.0 IF (M .LT. 1) GO TO 50 C = 1.0 DO 41 I = 1,M B0 = B0 - 1.0 41 C = C*(B0/(A0 + B0)) U = ALOG(C) + U C 50 Z = A*ALOG(X) - U B0 = B0 - 1.0 APB = A0 + B0 IF (APB .GT. 1.0) GO TO 51 T = 1.0 + GAM1(APB) GO TO 52 51 U = DBLE(A0) + DBLE(B0) - 1.D0 T = (1.0 + GAM1(U))/APB 52 BPSER = EXP(Z)*(A0/A)*(1.0 + GAM1(B0))/T GO TO 70 C C PROCEDURE FOR A0 .LT. 1 AND B0 .GE. 8 C 60 U = GAMLN1(A0) + ALGDIV(A0,B0) Z = A*ALOG(X) - U BPSER = (A0/A)*EXP(Z) 70 IF (BPSER .EQ. 0.0 .OR. A .LE. 0.1*EPS) RETURN C----------------------------------------------------------------------- C COMPUTE THE SERIES C----------------------------------------------------------------------- SUM = 0.0 N = 0.0 C = 1.0 TOL = EPS/A 100 N = N + 1.0 C = C*(0.5 + (0.5 - B/N))*X W = C/(A + N) SUM = SUM + W IF (ABS(W) .GT. TOL) GO TO 100 BPSER = BPSER*(1.0 + A*SUM) RETURN END REAL FUNCTION BUP(A, B, X, Y, N, EPS) C----------------------------------------------------------------------- C EVALUATION OF IX(A,B) - IX(A+N,B) WHERE N IS A POSITIVE INTEGER. C EPS IS THE TOLERANCE USED. C----------------------------------------------------------------------- REAL L C C OBTAIN THE SCALING FACTOR EXP(-MU) AND C EXP(MU)*(X**A*Y**B/BETA(A,B))/A C APB = A + B AP1 = A + 1.0 MU = 0 D = 1.0 IF (N .EQ. 1 .OR. A .LT. 1.0) GO TO 10 IF (APB .LT. 1.1*AP1) GO TO 10 MU = ABS(EXPARG(1)) K = EXPARG(0) IF (K .LT. MU) MU = K T = MU D = EXP(-T) C 10 BUP = BRCMP1(MU,A,B,X,Y)/A IF (N .EQ. 1 .OR. BUP .EQ. 0.0) RETURN NM1 = N - 1 W = D C C LET K BE THE INDEX OF THE MAXIMUM TERM C K = 0 IF (B .LE. 1.0) GO TO 40 IF (Y .GT. 1.E-4) GO TO 20 K = NM1 GO TO 30 20 R = (B - 1.0)*X/Y - A IF (R .LT. 1.0) GO TO 40 K = NM1 T = NM1 IF (R .LT. T) K = R C C ADD THE INCREASING TERMS OF THE SERIES C 30 DO 31 I = 1,K L = I - 1 D = ((APB + L)/(AP1 + L))*X*D W = W + D 31 CONTINUE IF (K .EQ. NM1) GO TO 50 C C ADD THE REMAINING TERMS OF THE SERIES C 40 KP1 = K + 1 DO 41 I = KP1,NM1 L = I - 1 D = ((APB + L)/(AP1 + L))*X*D W = W + D IF (D .LE. EPS*W) GO TO 50 41 CONTINUE C C TERMINATE THE PROCEDURE C 50 BUP = BUP*W RETURN END REAL FUNCTION BFRAC(A, B, X, Y, LAMBDA, EPS) C----------------------------------------------------------------------- C CONTINUED FRACTION EXPANSION FOR IX(A,B) WHEN A,B .GT. 1. C IT IS ASSUMED THAT LAMBDA = (A + B)*Y - B. C----------------------------------------------------------------------- REAL LAMBDA, N C-------------------- BFRAC = BRCOMP(A,B,X,Y) IF (BFRAC .EQ. 0.0) RETURN C C = 1.0 + LAMBDA C0 = B/A C1 = 1.0 + 1.0/A YP1 = Y + 1.0 C N = 0.0 P = 1.0 S = A + 1.0 AN = 0.0 BN = 1.0 ANP1 = 1.0 BNP1 = C/C1 R = C1/C C C CONTINUED FRACTION CALCULATION C 10 N = N + 1.0 T = N/A W = N*(B - N)*X E = A/S ALPHA = (P*(P + C0)*E*E)*(W*X) E = (1.0 + T)/(C1 + T + T) BETA = N + W/S + E*(C + N*YP1) P = 1.0 + T S = S + 2.0 C C UPDATE AN, BN, ANP1, AND BNP1 C T = ALPHA*AN + BETA*ANP1 AN = ANP1 ANP1 = T T = ALPHA*BN + BETA*BNP1 BN = BNP1 BNP1 = T C R0 = R R = ANP1/BNP1 IF (ABS(R - R0) .LE. EPS*R) GO TO 20 C C RESCALE AN, BN, ANP1, AND BNP1 C AN = AN/BNP1 BN = BN/BNP1 ANP1 = R BNP1 = 1.0 GO TO 10 C C TERMINATION C 20 BFRAC = BFRAC*R RETURN END REAL FUNCTION BRCOMP (A, B, X, Y) C----------------------------------------------------------------------- C EVALUATION OF X**A*Y**B/BETA(A,B) C----------------------------------------------------------------------- REAL LAMBDA, LNX, LNY C----------------- C CONST = 1/SQRT(2*PI) C----------------- DATA CONST/.398942280401433/ C BRCOMP = 0.0 IF (X .EQ. 0.0 .OR. Y .EQ. 0.0) RETURN A0 = AMIN1(A,B) IF (A0 .GE. 8.0) GO TO 100 C IF (X .GT. 0.375) GO TO 10 LNX = ALOG(X) LNY = ALNREL(-X) GO TO 20 10 IF (Y .GT. 0.375) GO TO 11 LNX = ALNREL(-Y) LNY = ALOG(Y) GO TO 20 11 LNX = ALOG(X) LNY = ALOG(Y) C 20 Z = A*LNX + B*LNY IF (A0 .LT. 1.0) GO TO 30 Z = Z - BETALN(A,B) BRCOMP = EXP(Z) RETURN C----------------------------------------------------------------------- C PROCEDURE FOR A .LT. 1 OR B .LT. 1 C----------------------------------------------------------------------- 30 B0 = AMAX1(A,B) IF (B0 .GE. 8.0) GO TO 80 IF (B0 .GT. 1.0) GO TO 60 C C ALGORITHM FOR B0 .LE. 1 C BRCOMP = EXP(Z) IF (BRCOMP .EQ. 0.0) RETURN C APB = A + B IF (APB .GT. 1.0) GO TO 40 Z = 1.0 + GAM1(APB) GO TO 50 40 U = DBLE(A) + DBLE(B) - 1.D0 Z = (1.0 + GAM1(U))/APB C 50 C = (1.0 + GAM1(A))*(1.0 + GAM1(B))/Z BRCOMP = BRCOMP*(A0*C)/(1.0 + A0/B0) RETURN C C ALGORITHM FOR 1 .LT. B0 .LT. 8 C 60 U = GAMLN1(A0) N = B0 - 1.0 IF (N .LT. 1) GO TO 70 C = 1.0 DO 61 I = 1,N B0 = B0 - 1.0 C = C*(B0/(A0 + B0)) 61 CONTINUE U = ALOG(C) + U C 70 Z = Z - U B0 = B0 - 1.0 APB = A0 + B0 IF (APB .GT. 1.0) GO TO 71 T = 1.0 + GAM1(APB) GO TO 72 71 U = DBLE(A0) + DBLE(B0) - 1.D0 T = (1.0 + GAM1(U))/APB 72 BRCOMP = A0*EXP(Z)*(1.0 + GAM1(B0))/T RETURN C C ALGORITHM FOR B0 .GE. 8 C 80 U = GAMLN1(A0) + ALGDIV(A0,B0) BRCOMP = A0*EXP(Z - U) RETURN C----------------------------------------------------------------------- C PROCEDURE FOR A .GE. 8 AND B .GE. 8 C----------------------------------------------------------------------- 100 IF (A .GT. B) GO TO 101 H = A/B X0 = H/(1.0 + H) Y0 = 1.0/(1.0 + H) LAMBDA = A - (A + B)*X GO TO 110 101 H = B/A X0 = 1.0/(1.0 + H) Y0 = H/(1.0 + H) LAMBDA = (A + B)*Y - B C 110 E = -LAMBDA/A IF (ABS(E) .GT. 0.6) GO TO 111 U = RLOG1(E) GO TO 120 111 U = E - ALOG(X/X0) C 120 E = LAMBDA/B IF (ABS(E) .GT. 0.6) GO TO 121 V = RLOG1(E) GO TO 130 121 V = E - ALOG(Y/Y0) C 130 Z = EXP(-(A*U + B*V)) BRCOMP = CONST*SQRT(B*X0)*Z*EXP(-BCORR(A,B)) RETURN END REAL FUNCTION BRCMP1 (MU, A, B, X, Y) C----------------------------------------------------------------------- C EVALUATION OF EXP(MU) * (X**A*Y**B/BETA(A,B)) C----------------------------------------------------------------------- REAL LAMBDA, LNX, LNY C----------------- C CONST = 1/SQRT(2*PI) C----------------- DATA CONST/.398942280401433/ C A0 = AMIN1(A,B) IF (A0 .GE. 8.0) GO TO 100 C IF (X .GT. 0.375) GO TO 10 LNX = ALOG(X) LNY = ALNREL(-X) GO TO 20 10 IF (Y .GT. 0.375) GO TO 11 LNX = ALNREL(-Y) LNY = ALOG(Y) GO TO 20 11 LNX = ALOG(X) LNY = ALOG(Y) C 20 Z = A*LNX + B*LNY IF (A0 .LT. 1.0) GO TO 30 Z = Z - BETALN(A,B) BRCMP1 = ESUM(MU,Z) RETURN C----------------------------------------------------------------------- C PROCEDURE FOR A .LT. 1 OR B .LT. 1 C----------------------------------------------------------------------- 30 B0 = AMAX1(A,B) IF (B0 .GE. 8.0) GO TO 80 IF (B0 .GT. 1.0) GO TO 60 C C ALGORITHM FOR B0 .LE. 1 C BRCMP1 = ESUM(MU,Z) IF (BRCMP1 .EQ. 0.0) RETURN C APB = A + B IF (APB .GT. 1.0) GO TO 40 Z = 1.0 + GAM1(APB) GO TO 50 40 U = DBLE(A) + DBLE(B) - 1.D0 Z = (1.0 + GAM1(U))/APB C 50 C = (1.0 + GAM1(A))*(1.0 + GAM1(B))/Z BRCMP1 = BRCMP1*(A0*C)/(1.0 + A0/B0) RETURN C C ALGORITHM FOR 1 .LT. B0 .LT. 8 C 60 U = GAMLN1(A0) N = B0 - 1.0 IF (N .LT. 1) GO TO 70 C = 1.0 DO 61 I = 1,N B0 = B0 - 1.0 C = C*(B0/(A0 + B0)) 61 CONTINUE U = ALOG(C) + U C 70 Z = Z - U B0 = B0 - 1.0 APB = A0 + B0 IF (APB .GT. 1.0) GO TO 71 T = 1.0 + GAM1(APB) GO TO 72 71 U = DBLE(A0) + DBLE(B0) - 1.D0 T = (1.0 + GAM1(U))/APB 72 BRCMP1 = A0*ESUM(MU,Z)*(1.0 + GAM1(B0))/T RETURN C C ALGORITHM FOR B0 .GE. 8 C 80 U = GAMLN1(A0) + ALGDIV(A0,B0) BRCMP1 = A0*ESUM(MU,Z - U) RETURN C----------------------------------------------------------------------- C PROCEDURE FOR A .GE. 8 AND B .GE. 8 C----------------------------------------------------------------------- 100 IF (A .GT. B) GO TO 101 H = A/B X0 = H/(1.0 + H) Y0 = 1.0/(1.0 + H) LAMBDA = A - (A + B)*X GO TO 110 101 H = B/A X0 = 1.0/(1.0 + H) Y0 = H/(1.0 + H) LAMBDA = (A + B)*Y - B C 110 E = -LAMBDA/A IF (ABS(E) .GT. 0.6) GO TO 111 U = RLOG1(E) GO TO 120 111 U = E - ALOG(X/X0) C 120 E = LAMBDA/B IF (ABS(E) .GT. 0.6) GO TO 121 V = RLOG1(E) GO TO 130 121 V = E - ALOG(Y/Y0) C 130 Z = ESUM(MU,-(A*U + B*V)) BRCMP1 = CONST*SQRT(B*X0)*Z*EXP(-BCORR(A,B)) RETURN END SUBROUTINE BGRAT(A, B, X, Y, W, EPS, IERR) C----------------------------------------------------------------------- C ASYMPTOTIC EXPANSION FOR IX(A,B) WHEN A IS LARGER THAN B. C THE RESULT OF THE EXPANSION IS ADDED TO W. IT IS ASSUMED C THAT A .GE. 15 AND B .LE. 1. EPS IS THE TOLERANCE USED. C IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS. C----------------------------------------------------------------------- REAL J, L, LNX, NU, N2 REAL C(30), D(30) C BM1 = (B - 0.5) - 0.5 NU = A + 0.5*BM1 IF (Y .GT. 0.375) GO TO 10 LNX = ALNREL(-Y) GO TO 11 10 LNX = ALOG(X) 11 Z = -NU*LNX IF (B*Z .EQ. 0.0) GO TO 100 C C COMPUTATION OF THE EXPANSION C SET R = EXP(-Z)*Z**B/GAMMA(B) C R = B*(1.0 + GAM1(B))*EXP(B*ALOG(Z)) R = R*EXP(A*LNX)*EXP(0.5*BM1*LNX) U = ALGDIV(B,A) + B*ALOG(NU) U = R*EXP(-U) IF (U .EQ. 0.0) GO TO 100 CALL GRAT1(B,Z,R,P,Q,EPS) C V = 0.25*(1.0/NU)**2 T2 = 0.25*LNX*LNX L = W/U J = Q/R SUM = J T = 1.0 CN = 1.0 N2 = 0.0 DO 22 N = 1,30 BP2N = B + N2 J = (BP2N*(BP2N + 1.0)*J + (Z + BP2N + 1.0)*T)*V N2 = N2 + 2.0 T = T*T2 CN = CN/(N2*(N2 + 1.0)) C(N) = CN S = 0.0 IF (N .EQ. 1) GO TO 21 NM1 = N - 1 COEF = B - N DO 20 I = 1,NM1 S = S + COEF*C(I)*D(N-I) 20 COEF = COEF + B 21 D(N) = BM1*CN + S/N DJ = D(N)*J SUM = SUM + DJ IF (SUM .LE. 0.0) GO TO 100 IF (ABS(DJ) .LE. EPS*(SUM + L)) GO TO 30 22 CONTINUE C C ADD THE RESULTS TO W C 30 IERR = 0 W = W + U*SUM RETURN C C THE EXPANSION CANNOT BE COMPUTED C 100 IERR = 1 RETURN END SUBROUTINE GRAT1 (A,X,R,P,Q,EPS) REAL J, L C----------------------------------------------------------------------- C EVALUATION OF THE INCOMPLETE GAMMA RATIO FUNCTIONS C P(A,X) AND Q(A,X) C C IT IS ASSUMED THAT A .LE. 1. EPS IS THE TOLERANCE TO BE USED. C THE INPUT ARGUMENT R HAS THE VALUE E**(-X)*X**A/GAMMA(A). C----------------------------------------------------------------------- IF (A*X .EQ. 0.0) GO TO 130 IF (A .EQ. 0.5) GO TO 120 IF (X .LT. 1.1) GO TO 10 GO TO 50 C C TAYLOR SERIES FOR P(A,X)/X**A C 10 AN = 3.0 C = X SUM = X/(A + 3.0) TOL = 0.1*EPS/(A + 1.0) 11 AN = AN + 1.0 C = -C*(X/AN) T = C/(A + AN) SUM = SUM + T IF (ABS(T) .GT. TOL) GO TO 11 J = A*X*((SUM/6.0 - 0.5/(A + 2.0))*X + 1.0/(A + 1.0)) C Z = A*ALOG(X) H = GAM1(A) G = 1.0 + H IF (X .LT. 0.25) GO TO 20 IF (A .LT. X/2.59) GO TO 40 GO TO 30 20 IF (Z .GT. -.13394) GO TO 40 C 30 W = EXP(Z) P = W*G*(0.5 + (0.5 - J)) Q = 0.5 + (0.5 - P) RETURN C 40 L = REXP(Z) W = 0.5 + (0.5 + L) Q = (W*J - L)*G - H IF (Q .LT. 0.0) GO TO 110 P = 0.5 + (0.5 - Q) RETURN C C CONTINUED FRACTION EXPANSION C 50 A2NM1 = 1.0 A2N = 1.0 B2NM1 = X B2N = X + (1.0 - A) C = 1.0 51 A2NM1 = X*A2N + C*A2NM1 B2NM1 = X*B2N + C*B2NM1 AM0 = A2NM1/B2NM1 C = C + 1.0 CMA = C - A A2N = A2NM1 + CMA*A2N B2N = B2NM1 + CMA*B2N AN0 = A2N/B2N IF (ABS(AN0 - AM0) .GE. EPS*AN0) GO TO 51 Q = R*AN0 P = 0.5 + (0.5 - Q) RETURN C C SPECIAL CASES C 100 P = 0.0 Q = 1.0 RETURN C 110 P = 1.0 Q = 0.0 RETURN C 120 IF (X .GE. 0.25) GO TO 121 P = ERF(SQRT(X)) Q = 0.5 + (0.5 - P) RETURN 121 Q = ERFC1(0,SQRT(X)) P = 0.5 + (0.5 - Q) RETURN C 130 IF (X .LE. A) GO TO 100 GO TO 110 END REAL FUNCTION BASYM(A, B, LAMBDA, EPS) C----------------------------------------------------------------------- C ASYMPTOTIC EXPANSION FOR IX(A,B) FOR LARGE A AND B. C LAMBDA = (A + B)*Y - B AND EPS IS THE TOLERANCE USED. C IT IS ASSUMED THAT LAMBDA IS NONNEGATIVE AND THAT C A AND B ARE GREATER THAN OR EQUAL TO 15. C----------------------------------------------------------------------- REAL J0, J1, LAMBDA REAL A0(21), B0(21), C(21), D(21) C------------------------ C ****** NUM IS THE MAXIMUM VALUE THAT N CAN TAKE IN THE DO LOOP C ENDING AT STATEMENT 50. IT IS REQUIRED THAT NUM BE EVEN. C THE ARRAYS A0, B0, C, D HAVE DIMENSION NUM + 1. C DATA NUM/20/ C------------------------ C E0 = 2/SQRT(PI) C E1 = 2**(-3/2) C------------------------ DATA E0/1.12837916709551/, E1/.353553390593274/ C------------------------ BASYM = 0.0 IF (A .GE. B) GO TO 10 H = A/B R0 = 1.0/(1.0 + H) R1 = (B - A)/B W0 = 1.0/SQRT(A*(1.0 + H)) GO TO 20 10 H = B/A R0 = 1.0/(1.0 + H) R1 = (B - A)/A W0 = 1.0/SQRT(B*(1.0 + H)) C 20 F = A*RLOG1(-LAMBDA/A) + B*RLOG1(LAMBDA/B) T = EXP(-F) IF (T .EQ. 0.0) RETURN Z0 = SQRT(F) Z = 0.5*(Z0/E1) Z2 = F + F C A0(1) = (2.0/3.0)*R1 C(1) = - 0.5*A0(1) D(1) = - C(1) J0 = (0.5/E0)*ERFC1(1,Z0) J1 = E1 SUM = J0 + D(1)*W0*J1 C S = 1.0 H2 = H*H HN = 1.0 W = W0 ZNM1 = Z ZN = Z2 DO 50 N = 2, NUM, 2 HN = H2*HN A0(N) = 2.0*R0*(1.0 + H*HN)/(N + 2.0) NP1 = N + 1 S = S + HN A0(NP1) = 2.0*R1*S/(N + 3.0) C DO 41 I = N, NP1 R = -0.5*(I + 1.0) B0(1) = R*A0(1) DO 31 M = 2, I BSUM = 0.0 MM1 = M - 1 DO 30 J = 1, MM1 MMJ = M - J 30 BSUM = BSUM + (J*R - MMJ)*A0(J)*B0(MMJ) 31 B0(M) = R*A0(M) + BSUM/M C(I) = B0(I)/(I + 1.0) C DSUM = 0.0 IM1 = I - 1 DO 40 J = 1, IM1 IMJ = I - J 40 DSUM = DSUM + D(IMJ)*C(J) 41 D(I) = -(DSUM + C(I)) C J0 = E1*ZNM1 + (N - 1.0)*J0 J1 = E1*ZN + N*J1 ZNM1 = Z2*ZNM1 ZN = Z2*ZN W = W0*W T0 = D(N)*W*J0 W = W0*W T1 = D(NP1)*W*J1 SUM = SUM + (T0 + T1) IF ((ABS(T0) + ABS(T1)) .LE. EPS*SUM) GO TO 60 50 CONTINUE C 60 U = EXP(-BCORR(A,B)) BASYM = E0*T*U*SUM RETURN END SUBROUTINE ISUBX (A0, B0, X0, P, IERR, EPS) REAL I, J, K, LAMBDA, M, N, W(10), Z(10) C ------------------- DATA W(1) /6.6671344308688E-2/, W(2) /1.4945134915058E-1/, 1 W(3) /2.1908636251598E-1/, W(4) /2.6926671931000E-1/, 2 W(5) /2.9552422471475E-1/, W(6) /2.9552422471475E-1/, 3 W(7) /2.6926671931000E-1/, W(8) /2.1908636251598E-1/, 4 W(9) /1.4945134915058E-1/, W(10)/6.6671344308688E-2/ DATA Z(1) /1.3046735791414E-2/, Z(2) /6.7468316655507E-2/, 1 Z(3) /1.6029521585049E-1/, Z(4) /2.8330230293538E-1/, 2 Z(5) /4.2556283050918E-1/, Z(6) /5.7443716949081E-1/, 3 Z(7) /7.1669769706462E-1/, Z(8) /8.3970478414951E-1/, 4 Z(9) /9.3253168334449E-1/, Z(10)/9.8695326420859E-1/ C ------------------- C RPINV = 1/SQRT(PI) C ------------------- DATA PIHALF /1.5707963267949/ DATA RPINV /.56418958354776/ C ------------------- C ****** MAX IS A MACHINE DEPENDENT CONSTANT. MAX IS THE C LARGEST POSITIVE INTEGER THAT MAY BE USED. C MAX = IPMPAR(3) C C ------------------- A = A0 B = B0 X = X0 Y = 0.5 + (0.5 - X) C C CHECK THE ARGUMENTS C P = 0.0 IERR = 1 IF (A .LT. 0.5 .OR. B .LT. 0.5) GO TO 410 IF (X .EQ. 0.0 .OR. X .EQ. 1.0) GO TO 300 IF (X .LT. 0.0) GO TO 400 M = MAX IF (A .GE. M .OR. B .GT. 70.0 .OR. Y .LT. 0.0) GO TO 411 K = INT(A) J = INT(B) AFRAC = A - K BFRAC = B - J IF ((AFRAC .NE. 0.0 .AND. AFRAC .NE. 0.5) .OR. * (BFRAC .NE. 0.0 .AND. BFRAC .NE. 0.5)) GO TO 420 IF (A .GE. 5000.0 .AND. X .LT. 0.96) RETURN C C CHECK IF B IS AN INTEGER C IND = 0 TOL = 0.5*AMAX1(EPS, 1.E-11) IF (BFRAC .NE. 0.0) GO TO 100 IF (AFRAC .NE. 0.0) GO TO 20 IF (A .GE. B) GO TO 20 C C INTERCHANGE A AND B C 10 IND = 1 T = B B = A A = T T = Y Y = X X = T T = J J = K K = T C C COMPUTE EXPANSION 14 C 20 AM1 = A - 1.0 N = 1.0 IF (AM1 .LT. 0.5) GO TO 30 N = J IF (Y .GE. 2.0*J*X) GO TO 30 T = AM1*Y/X + 1.0 IF (T .LT. J) N = INT(T) C 30 I = N - 1.0 C = (A*ALOG(X) + I*ALNREL(-X)) - BLND(A,I) IF (C .LE. -30) GO TO 60 TOL = TOL/J AN = EXP(C) IF (AN .LE. TOL) GO TO 60 IF (AN .GE. 1.0 - TOL) GO TO 330 C C = AN SUM = 0.0 40 I = I + 1.0 IF (I .GE. J) GO TO 50 C = ((AM1 + I)/I)*Y*C SUM = SUM + C IF (C .GT. TOL) GO TO 40 C 50 I = N C = AN 51 I = I - 1.0 IF (I .EQ. 0.0) GO TO 52 C = I*C/((I + AM1)*Y) SUM = SUM + C IF (C .GT. TOL) GO TO 51 52 P = AN + SUM C 60 IF (P .GE. 1.0) P = 1.0 IF (IND .EQ. 0) RETURN P = 0.5 + (0.5 - P) IF (P .LT. 0.0) P = 0.0 RETURN C C SELECTION OF THE APPROPRIATE ALGORITHM C 100 AM1 = A - 1.0 IF (A .GT. 70.0) GO TO 150 IF (AFRAC .EQ. 0.0) GO TO 10 C C COMPUTE P0 = IX(A,1/2) OR P0 = IX(1/2,B) C USING FORMULA 22 C TEMP = SQRT(X) RTY = SQRT(Y) C = ATAN(TEMP/RTY)/PIHALF IF (K .EQ. 0.0) GO TO 130 IND = J M = K + K TEMP = -TEMP C 110 I = 0.0 T = 1.0 SUM = 0.0 111 I = I + 2.0 IF (I .EQ. M) GO TO 120 T = X*(I/(I + 1.0))*T SUM = T + SUM GO TO 111 C 120 P0 = (SUM + 1.0)*TEMP*RTY/PIHALF + C IF (IND .NE. 0) GO TO 200 P = P0 RETURN C 130 IF (J .EQ. 0.0) GO TO 310 M = J + J X = Y GO TO 110 C C COMPUTE P0 = IX(A,1/2) FOR A .GT. 70 C USING EXPANSION 52 OR 53 C 150 P0 = 0.0 IF (X .LT. 0.7) GO TO 200 T = TOL**(1.0/AM1) IF (X .LE. T) GO TO 200 C T = 0.5 + (0.5 - T) LAMBDA = SQRT(T) RTY = SQRT(Y) GAMRAT = RPINV*EXP(-ALGDIV(0.5,A)) IF (T .GE. 4.0*Y) GO TO 170 C C = LAMBDA - RTY TEMP = 2.0*RTY SUM = 0.0 DO 160 L = 1,10 T = C*Z(L) 160 SUM = SUM + W(L)*(X - T*(T + TEMP))**AM1 P0 = C*GAMRAT*SUM + 0.5*TOL GO TO 200 C 170 SUM = 0.0 DO 171 L = 1,10 T = 1.0 - Y*Z(L)*Z(L) 171 SUM = SUM + W(L)*T**AM1 P0 = 1.0 - RTY*GAMRAT*SUM C C COMPUTE P USING EXPANSION 21 C 200 IF (J .EQ. 0.0) GO TO 251 N = J IF (Y .GE. 2.0*J*X) GO TO 210 T = AM1*Y/X + 0.5 IF (T .GE. 2.0) GO TO 201 N = 1.0 GO TO 210 201 IF (T .LT. J) N = INT(T) C 210 T = N - 0.5 C = (A*ALOG(X) + T*ALNREL(-X)) - BLND(A,T) IF (C .LE. -30.0) GO TO 251 C = EXP(C) IF (C .LE. TOL/J) GO TO 251 IF (P0 + C .GE. 1.0 - TOL) GO TO 320 C TOL = TOL/J LAMBDA = C SUM = 0.0 220 T = T + 1.0 IF (T .GT. J) GO TO 240 LAMBDA = (AM1 + T)*Y*LAMBDA/T SUM = SUM + LAMBDA IF (LAMBDA .GT. TOL) GO TO 220 C 240 LAMBDA = C T = A - 0.5 I = N 241 I = I - 1.0 IF (I .LE. 0.0) GO TO 250 LAMBDA = ((I + 0.5)/(I + T))*LAMBDA/Y SUM = LAMBDA + SUM IF (LAMBDA .GT. TOL) GO TO 241 C 250 P = C + SUM 251 P = P + P0 IF (P .GE. 1.0) P = 1.0 RETURN C C SPECIAL CASES C 300 P = X RETURN C 310 P = C RETURN C 320 P = 1.0 RETURN C 330 P = 1 - IND RETURN C C ERROR RETURN C 400 IERR = 2 RETURN C 410 IF (A .LE. 0.0 .OR. B .LE. 0.0) GO TO 400 411 IERR = 3 RETURN C 420 IERR = 4 RETURN END REAL FUNCTION BLND(A,B) REAL LOGAM C IF (A .GT. 20.0) GO TO 10 BLND = (LOGAM(A) - LOGAM(A + B)) + LOGAM(B + 1.0) RETURN 10 BLND = ALGDIV(B,A) + LOGAM(B + 1.0) RETURN END REAL FUNCTION LOGAM (X) REAL W(200) C ------------------------------------------------------------------ C COMPUTATION OF LN(GAMMA(X)) FOR X = N/2 WHERE N IS AN INTEGER C ------------------------------------------------------------------ C D = 0.5*(LN(2*PI) - 1) C --------------------- DATA D/.41893853320467/ C --------------------- DATA W(1) /.57236494292470E+00/, W(2) /0.0/, * W(3) /-.12078223763525E+00/, W(4) /0.0/, * W(5) /.28468287047292E+00/, W(6) /.69314718055995E+00/, * W(7) /.12009736023471E+01/, W(8) /.17917594692281E+01/, * W(9) /.24537365708424E+01/, W(10) /.31780538303479E+01/, * W(11) /.39578139676187E+01/, W(12) /.47874917427820E+01/, * W(13) /.56625620598571E+01/, W(14) /.65792512120101E+01/, * W(15) /.75343642367587E+01/, W(16) /.85251613610654E+01/, * W(17) /.95492672573010E+01/, W(18) /.10604602902745E+02/, * W(19) /.11689333420797E+02/, W(20) /.12801827480081E+02/ DATA W(21) /.13940625219404E+02/, W(22) /.15104412573076E+02/, * W(23) /.16292000476567E+02/, W(24) /.17502307845874E+02/, * W(25) /.18734347511936E+02/, W(26) /.19987214495662E+02/, * W(27) /.21260076156245E+02/, W(28) /.22552163853123E+02/, * W(29) /.23862765841689E+02/, W(30) /.25191221182739E+02/, * W(31) /.26536914491116E+02/, W(32) /.27899271383841E+02/, * W(33) /.29277754515041E+02/, W(34) /.30671860106081E+02/, * W(35) /.32081114895947E+02/, W(36) /.33505073450137E+02/, * W(37) /.34943315776877E+02/, W(38) /.36395445208033E+02/, * W(39) /.37861086508961E+02/, W(40) /.39339884187199E+02/ DATA W(41) /.40831500974531E+02/, W(42) /.42335616460753E+02/, * W(43) /.43851925860675E+02/, W(44) /.45380138898477E+02/, * W(45) /.46919978795809E+02/, W(46) /.48471181351835E+02/, * W(47) /.50033494105019E+02/, W(48) /.51606675567764E+02/, * W(49) /.53190494526169E+02/, W(50) /.54784729398112E+02/, * W(51) /.56389167643720E+02/, W(52) /.58003605222981E+02/, * W(53) /.59627846095884E+02/, W(54) /.61261701761002E+02/, * W(55) /.62904990828877E+02/, W(56) /.64557538627006E+02/, * W(57) /.66219176833549E+02/, W(58) /.67889743137182E+02/, * W(59) /.69569080920824E+02/, W(60) /.71257038967168E+02/ DATA W(61) /.72953471184169E+02/, W(62) /.74658236348830E+02/, * W(63) /.76371197867783E+02/, W(64) /.78092223553315E+02/, * W(65) /.79821185413614E+02/, W(66) /.81557959456115E+02/, * W(67) /.83302425502950E+02/, W(68) /.85054467017582E+02/, * W(69) /.86813970941781E+02/, W(70) /.88580827542198E+02/, * W(71) /.90354930265818E+02/, W(72) /.92136175603687E+02/, * W(73) /.93924462962300E+02/, W(74) /.95719694542143E+02/, * W(75) /.97521775222888E+02/, W(76) /.99330612454787E+02/, * W(77) /.10114611615586E+03/, W(78) /.10296819861451E+03/, * W(79) /.10479677439716E+03/, W(80) /.10663176026064E+03/ DATA W(81) /.10847307506907E+03/, W(82) /.11032063971476E+03/, * W(83) /.11217437704318E+03/, W(84) /.11403421178146E+03/, * W(85) /.11590007047041E+03/, W(86) /.11777188139975E+03/, * W(87) /.11964957454634E+03/, W(88) /.12153308151544E+03/, * W(89) /.12342233548444E+03/, W(90) /.12531727114936E+03/, * W(91) /.12721782467361E+03/, W(92) /.12912393363913E+03/, * W(93) /.13103553699957E+03/, W(94) /.13295257503562E+03/, * W(95) /.13487498931216E+03/, W(96) /.13680272263733E+03/, * W(97) /.13873571902320E+03/, W(98) /.14067392364823E+03/, * W(99) /.14261728282115E+03/, W(100)/.14456574394634E+03/ DATA W(101)/.14651925549072E+03/, W(102)/.14847776695177E+03/, * W(103)/.15044122882700E+03/, W(104)/.15240959258450E+03/, * W(105)/.15438281063467E+03/, W(106)/.15636083630308E+03/, * W(107)/.15834362380427E+03/, W(108)/.16033112821663E+03/, * W(109)/.16232330545817E+03/, W(110)/.16432011226320E+03/, * W(111)/.16632150615984E+03/, W(112)/.16832744544843E+03/, * W(113)/.17033788918059E+03/, W(114)/.17235279713916E+03/, * W(115)/.17437212981875E+03/, W(116)/.17639584840700E+03/, * W(117)/.17842391476655E+03/, W(118)/.18045629141754E+03/, * W(119)/.18249294152079E+03/, W(120)/.18453382886145E+03/ DATA W(121)/.18657891783334E+03/, W(122)/.18862817342367E+03/, * W(123)/.19068156119837E+03/, W(124)/.19273904728784E+03/, * W(125)/.19480059837319E+03/, W(126)/.19686618167289E+03/, * W(127)/.19893576492993E+03/, W(128)/.20100931639928E+03/, * W(129)/.20308680483583E+03/, W(130)/.20516819948264E+03/, * W(131)/.20725347005963E+03/, W(132)/.20934258675254E+03/, * W(133)/.21143552020227E+03/, W(134)/.21353224149456E+03/, * W(135)/.21563272214993E+03/, W(136)/.21773693411395E+03/, * W(137)/.21984484974781E+03/, W(138)/.22195644181913E+03/, * W(139)/.22407168349308E+03/, W(140)/.22619054832373E+03/ DATA W(141)/.22831301024565E+03/, W(142)/.23043904356578E+03/, * W(143)/.23256862295547E+03/, W(144)/.23470172344282E+03/, * W(145)/.23683832040517E+03/, W(146)/.23897838956183E+03/, * W(147)/.24112190696703E+03/, W(148)/.24326884900298E+03/, * W(149)/.24541919237325E+03/, W(150)/.24757291409619E+03/, * W(151)/.24972999149863E+03/, W(152)/.25189040220972E+03/, * W(153)/.25405412415489E+03/, W(154)/.25622113555001E+03/, * W(155)/.25839141489572E+03/, W(156)/.26056494097186E+03/, * W(157)/.26274169283208E+03/, W(158)/.26492164979855E+03/, * W(159)/.26710479145687E+03/, W(160)/.26929109765102E+03/ DATA W(161)/.27148054847853E+03/, W(162)/.27367312428569E+03/, * W(163)/.27586880566295E+03/, W(164)/.27806757344037E+03/, * W(165)/.28026940868320E+03/, W(166)/.28247429268763E+03/, * W(167)/.28468220697654E+03/, W(168)/.28689313329543E+03/, * W(169)/.28910705360840E+03/, W(170)/.29132395009427E+03/, * W(171)/.29354380514276E+03/, W(172)/.29576660135076E+03/, * W(173)/.29799232151870E+03/, W(174)/.30022094864701E+03/, * W(175)/.30245246593264E+03/, W(176)/.30468685676567E+03/, * W(177)/.30692410472600E+03/, W(178)/.30916419358015E+03/, * W(179)/.31140710727802E+03/, W(180)/.31365282994988E+03/ DATA W(181)/.31590134590330E+03/, W(182)/.31815263962021E+03/, * W(183)/.32040669575401E+03/, W(184)/.32266349912673E+03/, * W(185)/.32492303472629E+03/, W(186)/.32718528770378E+03/, * W(187)/.32945024337081E+03/, W(188)/.33171788719693E+03/, * W(189)/.33398820480710E+03/, W(190)/.33626118197920E+03/, * W(191)/.33853680464160E+03/, W(192)/.34081505887080E+03/, * W(193)/.34309593088909E+03/, W(194)/.34537940706227E+03/, * W(195)/.34766547389743E+03/, W(196)/.34995411804077E+03/, * W(197)/.35224532627544E+03/, W(198)/.35453908551944E+03/, * W(199)/.35683538282361E+03/, W(200)/.35913420536958E+03/ C ------------------------------------------------------------------ IF (X .GT. 100.0) GO TO 10 N = 2.0*X + 0.1 LOGAM = W(N) RETURN 10 T = (1.0/X)**2 Z = (((-0.75*T + 1.0)*T - 3.5)*T + 105.0)/(X*1260.0) LOGAM = (D + Z) + (X - 0.5)*(ALOG(X) - 1.0) RETURN END SUBROUTINE CBSSLJ (Z, CNU, W) C----------------------------------------------------------------------- C C EVALUATION OF THE COMPLEX BESSEL FUNCTION J (Z) C CNU C----------------------------------------------------------------------- C C WRITTEN BY C ANDREW H. VAN TUYL AND ALFRED H. MORRIS, JR. C NAVAL SURFACE WARFARE CENTER C OCTOBER, 1991 C C A MODIFICATION OF THE PROCEDURE DEVELOPED BY ALLEN V. HERSHEY C (NAVAL SURFACE WARFARE CENTER) IN 1978 FOR HANDLING THE DEBYE C APPROXIMATION IS EMPLOYED. C C----------------------------------------------------------------------- COMPLEX Z, CNU, W COMPLEX C, NU, S, SM1, SM2, T, TSC, W0, W1, ZN, ZZ COMPLEX CDIV, CGAM0 C----------------------- DATA PI /3.14159265358979/ C----------------------- X = REAL(Z) Y = AIMAG(Z) R = CPABS(X,Y) CN1 = REAL(CNU) CN2 = AIMAG(CNU) RN2 = CN1*CN1 + CN2*CN2 PN = AINT(CN1) FN = CN1 - PN C C CALCULATION WHEN ORDER IS AN INTEGER C SN = 1.0 IF (FN .NE. 0.0 .OR. CN2 .NE. 0.0) GO TO 10 N = PN PN = ABS(PN) CN1 = PN IF (N .LT. 0 .AND. N .NE. (N/2)*2) SN = -1.0 C C SELECTION OF METHOD C 10 IF (R .LE. 17.5) GO TO 20 IF (R .GT. 17.5 + 0.5*RN2) GO TO 40 GO TO 50 C C USE MACLAURIN EXPANSION AND RECURSION C 20 IF (CN1 .GE. 0.0) GO TO 30 QN = -1.25*(R + 0.5*ABS(CN2) - ABS(Y - 0.5*CN2)) IF (CN1 .GE. QN) GO TO 30 QN = 1.25*(R - AMAX1(1.2*R,ABS(Y - CN2))) IF (CN1 .GE. QN) GO TO 30 QN = AMIN1(PN, -AINT(1.25*(R - ABS(CN2)))) GO TO 130 C 30 R2 = R*R QM = 0.0625*R2*R2 - CN2*CN2 QN = AMAX1(PN, AINT(SQRT(0.5*(QM + ABS(QM))))) GO TO 130 C C USE ASYMPTOTIC EXPANSION C 40 CALL CBJA(Z, CNU, W) RETURN C C CALCULATION FOR 17.5 .LT. ABS(Z) .LE. 17.5 + 0.5*ABS(CNU)**2 C 50 N = 0 IF (ABS(CN2) .GE. 0.8*ABS(Y)) GO TO 60 QM = -1.25*(R + 0.5*ABS(CN2) - ABS(Y - 0.5*CN2)) IF (CN1 .GE. QM) GO TO 60 QM = 1.25*(R - AMAX1(1.2*R,ABS(Y - CN2))) IF (CN1 .LT. QM) N = 1 C 60 QN = PN A = 4.E-3*R*R ZZ = Z IF (X .LT. 0.0) ZZ = -Z C C CALCULATION OF ZONE OF EXCLUSION OF DEBYE APPROXIMATION C 70 NU = CMPLX(QN + FN, CN2) ZN = NU/Z T2 = AIMAG(ZN)*AIMAG(ZN) U = 1.0 - REAL(ZN) T1 = U*U + T2 U = 1.0 + REAL(ZN) T2 = U*U + T2 U = T1*T2 V = A*U/(T1*T1 + T2*T2) IF (U*V*V .GT. 1.0) GO TO 80 C C THE ARGUMENT LIES INSIDE THE ZONE OF EXCLUSION C QN = QN + 1.0 IF (N .EQ. 0) GO TO 70 C C USE MACLAURIN EXPANSION WITH FORWARD RECURRENCE C QN = AMIN1(PN, -AINT(1.25*(R - ABS(CN2)))) GO TO 130 C C USE BACKWARD RECURRENCE STARTING FROM THE C ASYMPTOTIC EXPANSION C 80 QNP1 = QN + 1.0 IF (ABS(QN) .GE. ABS(PN)) GO TO 100 IF (R .LT. 17.5 + 0.5*(QNP1*QNP1 + CN2*CN2)) GO TO 100 C NU = CMPLX(QN + FN, CN2) CALL CBJA (ZZ, NU, SM1) NU = CMPLX(QNP1 + FN, CN2) CALL CBJA (ZZ, NU, SM2) GO TO 110 C C USE BACKWARD RECURRENCE STARTING FROM THE C DEBYE APPROXIMATION C 100 NU = CMPLX(QN + FN, CN2) CALL CBDB (ZZ, NU, FN, SM1) IF (QN .EQ. PN) GO TO 120 NU = CMPLX(QNP1 + FN, CN2) CALL CBDB (ZZ, NU, FN, SM2) C 110 NU = CMPLX(QN + FN, CN2) TSC = 2.0*NU*SM1/ZZ - SM2 SM2 = SM1 SM1 = TSC QN = QN - 1.0 IF (QN .NE. PN) GO TO 110 C 120 W = SM1 IF (SN .LT. 0.0) W = -W IF (X .GE. 0.0) RETURN C NU = PI*CMPLX(-CN2, CN1) IF (Y .LT. 0.0) NU = -NU W = CEXP(NU)*W RETURN C C USE MACLAURIN EXPANSION WITH FORWARD OR BACKWARD RECURRENCE. C 130 M = QN - PN IF (IABS(M) .GT. 1) GO TO 140 NU = CMPLX(CN1, CN2) CALL CBJM (Z, NU, W) GO TO 180 140 NU = CMPLX(QN + FN, CN2) CALL CBJM (Z, NU, W1) W0 = 0.25*Z*Z IF (M .GT. 0) GO TO 160 C C FORWARD RECURRENCE C M = IABS(M) NU = NU + 1.0 CALL CBJM (Z, NU, W) DO 150 I = 2,M C = NU*(NU + 1.0) T = (C/W0)*(W - W1) W1 = W W = T NU = NU + 1.0 150 CONTINUE GO TO 180 C C BACKWARD RECURRENCE C 160 NU = NU - 1.0 CALL CBJM (Z, NU, W) DO 170 I = 2,M C = NU*(NU + 1.0) T = (W0/C)*W1 W1 = W W = W - T NU = NU - 1.0 170 CONTINUE C C FINAL ASSEMBLY C 180 IF (FN .NE. 0.0 .OR. CN2 .NE. 0.0) GO TO 190 K = PN IF (K .EQ. 0.0) RETURN E = SN/GAMMA(PN + 1.0) W = E*W*(0.5*Z)**K RETURN C 190 S = CNU*CLOG(0.5*Z) W = CEXP(S)*W IF (RN2 .GT. 0.81) GO TO 200 W = W*CGAM0(CNU) RETURN 200 CALL CGAMMA(0, CNU, T) W = CDIV(W, CNU*T) RETURN END SUBROUTINE CBJM (Z, CNU, W) C----------------------------------------------------------------------- C C COMPUTATION OF (Z/2)**(-CNU) * GAMMA(CNU + 1) * J(CNU,Z) C C ----------------- C C THE MACLAURIN EXPANSION IS USED. IT IS ASSUMED THAT CNU IS NOT C A NEGATIVE INTEGER. C C----------------------------------------------------------------------- COMPLEX CNU, NU, NUP1, P, S, SN, T, TI, W, Z REAL INU, M COMPLEX CDIV C-------------------------- ANORM(Z) = AMAX1(ABS(REAL(Z)),ABS(AIMAG(Z))) C-------------------------- C C ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE C SMALLEST NUMBER SUCH THAT 1.0 + EPS .GT. 1.0 . C EPS = SPMPAR(1) C C-------------------------- S = -0.25*(Z*Z) NU = CNU RNU = REAL(NU) INU = AIMAG(NU) A = 0.5 + (0.5 + RNU) NUP1 = CMPLX(A, INU) C IF (A .LE. 0.0) GO TO 10 M = 1.0 T = S/NUP1 W = 1.0 + T GO TO 70 C C ADD 1.0 AND THE FIRST K-1 TERMS C 10 K = INT(-A) + 2 KM1 = K - 1 W = (1.0, 0.0) T = W DO 20 I = 1,KM1 M = I T = T*(S/(M*(NU + M))) W = W + T IF (ANORM(T) .LE. EPS*ANORM(W)) GO TO 30 20 CONTINUE GO TO 70 C C CHECK IF THE (K-1)-ST AND K-TH TERMS CAN BE IGNORED. C IF SO THEN THE SUMMATION IS COMPLETE. C 30 IF (I .EQ. KM1) GO TO 70 IMIN = I + 1 IF (IMIN .GE. K - 5) GO TO 50 TI = T C M = KM1 T = S/(NU + M) A0 = ANORM(T)/M T = T * (S/(NU + (M + 1.0))) A = ANORM(T)/(M*(M + 1.0)) A = AMAX1(A, A0) C T = (1.0, 0.0) KM2 = K - 2 DO 40 I = IMIN,KM2 M = I T = T*(S/(M*(NU + M))) IF (A*ANORM(T) .LT. 0.5) RETURN 40 CONTINUE T = T*TI IMIN = KM2 C C ADD THE (K-1)-ST TERM C 50 A = 1.0 P = (1.0, 0.0) SN = P DO 60 I = IMIN,KM1 M = I A = A*M P = P*(NU + M) SN = S*SN 60 CONTINUE T = T*(CDIV(SN,P)/A) W = W + T C C ADD THE REMAINING TERMS C 70 M = M + 1.0 T = T*(S/(M*(NU + M))) W = W + T IF (ANORM(T) .GT. EPS*ANORM(W)) GO TO 70 C RETURN END SUBROUTINE CBDB (CZ, CNU, FN, W) C----------------------------------------------------------------------- C C CALCULATION OF J (CZ) BY THE DEBYE APPROXIMATION C CNU C ------------------ C C IT IS ASSUMED THAT REAL(CZ) .GE. 0 AND THAT REAL(CNU) = FN + K C WHERE K IS AN INTEGER. C C----------------------------------------------------------------------- COMPLEX CZ, CNU, W REAL A(136), IS, INU, IZN COMPLEX C1, C2, ETA, J, NU, P, P1, Q, R, S, S1, S2, SM, T, Z, ZN C---------------------- C C = 1/SQRT(2) C BND = PI/3 C---------------------- DATA J /(0.0, 1.0)/ DATA C /.398942280401433/ DATA PI /3.14159265358979/ DATA PI2 /6.28318530717959/ DATA BND /1.04719755119660/ C---------------------- C C COEFFICIENTS OF THE FIRST 16 POLYNOMIALS C IN THE DEBYE APPROXIMATION C C DATA A(1) /1.0/ DATA A(2) /-.208333333333333E+00/, A(3) / .125000000000000E+00/ DATA A(4) / .334201388888889E+00/, A(5) /-.401041666666667E+00/, * A(6) / .703125000000000E-01/ DATA A(7) /-.102581259645062E+01/, A(8) / .184646267361111E+01/, * A(9) /-.891210937500000E+00/, A(10) / .732421875000000E-01/ DATA A(11) / .466958442342625E+01/, A(12) /-.112070026162230E+02/, * A(13) / .878912353515625E+01/, A(14) /-.236408691406250E+01/, * A(15) / .112152099609375E+00/ DATA A(16) /-.282120725582002E+02/, A(17) / .846362176746007E+02/, * A(18) /-.918182415432400E+02/, A(19) / .425349987453885E+02/, * A(20) /-.736879435947963E+01/, A(21) / .227108001708984E+00/ DATA A(22) / .212570130039217E+03/, A(23) /-.765252468141182E+03/, * A(24) / .105999045252800E+04/, A(25) /-.699579627376133E+03/, * A(26) / .218190511744212E+03/, A(27) /-.264914304869516E+02/, * A(28) / .572501420974731E+00/ DATA A(29) /-.191945766231841E+04/, A(30) / .806172218173731E+04/, * A(31) /-.135865500064341E+05/, A(32) / .116553933368645E+05/, * A(33) /-.530564697861340E+04/, A(34) / .120090291321635E+04/, * A(35) /-.108090919788395E+03/, A(36) / .172772750258446E+01/ DATA A(37) / .202042913309661E+05/, A(38) /-.969805983886375E+05/, * A(39) / .192547001232532E+06/, A(40) /-.203400177280416E+06/, * A(41) / .122200464983017E+06/, A(42) /-.411926549688976E+05/, * A(43) / .710951430248936E+04/, A(44) /-.493915304773088E+03/, * A(45) / .607404200127348E+01/ DATA A(46) /-.242919187900551E+06/, A(47) / .131176361466298E+07/, * A(48) /-.299801591853811E+07/, A(49) / .376327129765640E+07/, * A(50) /-.281356322658653E+07/, A(51) / .126836527332162E+07/, * A(52) /-.331645172484564E+06/, A(53) / .452187689813627E+05/, * A(54) /-.249983048181121E+04/, A(55) / .243805296995561E+02/ DATA A(56) / .328446985307204E+07/, A(57) /-.197068191184322E+08/, * A(58) / .509526024926646E+08/, A(59) /-.741051482115327E+08/, * A(60) / .663445122747290E+08/, A(61) /-.375671766607634E+08/, * A(62) / .132887671664218E+08/, A(63) /-.278561812808645E+07/, * A(64) / .308186404612662E+06/, A(65) /-.138860897537170E+05/, * A(66) / .110017140269247E+03/ DATA A(67) /-.493292536645100E+08/, A(68) / .325573074185766E+09/, * A(69) /-.939462359681578E+09/, A(70) / .155359689957058E+10/, * A(71) /-.162108055210834E+10/, A(72) / .110684281682301E+10/, * A(73) /-.495889784275030E+09/, A(74) / .142062907797533E+09/, * A(75) /-.244740627257387E+08/, A(76) / .224376817792245E+07/, * A(77) /-.840054336030241E+05/, A(78) / .551335896122021E+03/ DATA A(79) / .814789096118312E+09/, A(80) /-.586648149205185E+10/, * A(81) / .186882075092958E+11/, A(82) /-.346320433881588E+11/, * A(83) / .412801855797540E+11/, A(84) /-.330265997498007E+11/, * A(85) / .179542137311556E+11/, A(86) /-.656329379261928E+10/, * A(87) / .155927986487926E+10/, A(88) /-.225105661889415E+09/, * A(89) / .173951075539782E+08/, A(90) /-.549842327572289E+06/, * A(91) / .303809051092238E+04/ DATA A(92) /-.146792612476956E+11/, A(93) / .114498237732026E+12/, * A(94) /-.399096175224466E+12/, A(95) / .819218669548577E+12/, * A(96) /-.109837515608122E+13/, A(97) / .100815810686538E+13/, * A(98) /-.645364869245377E+12/, A(99) / .287900649906151E+12/, * A(100)/-.878670721780233E+11/, A(101)/ .176347306068350E+11/, * A(102)/-.216716498322380E+10/, A(103)/ .143157876718889E+09/, * A(104)/-.387183344257261E+07/, A(105)/ .182577554742932E+05/ DATA A(106)/ .286464035717679E+12/, A(107)/-.240629790002850E+13/, * A(108)/ .910934118523990E+13/, A(109)/-.205168994109344E+14/, * A(110)/ .305651255199353E+14/, A(111)/-.316670885847852E+14/, * A(112)/ .233483640445818E+14/, A(113)/-.123204913055983E+14/, * A(114)/ .461272578084913E+13/, A(115)/-.119655288019618E+13/, * A(116)/ .205914503232410E+12/, A(117)/-.218229277575292E+11/, * A(118)/ .124700929351271E+10/, A(119)/-.291883881222208E+08/, * A(120)/ .118838426256783E+06/ DATA A(121)/-.601972341723401E+13/, A(122)/ .541775107551060E+14/, * A(123)/-.221349638702525E+15/, A(124)/ .542739664987660E+15/, * A(125)/-.889496939881026E+15/, A(126)/ .102695519608276E+16/, * A(127)/-.857461032982895E+15/, A(128)/ .523054882578445E+15/, * A(129)/-.232604831188940E+15/, A(130)/ .743731229086791E+14/, * A(131)/-.166348247248925E+14/, A(132)/ .248500092803409E+13/, * A(133)/-.229619372968246E+12/, A(134)/ .114657548994482E+11/, * A(135)/-.234557963522252E+09/, A(136)/ .832859304016289E+06/ C---------------------- Z = CZ NU = CNU INU = AIMAG(CNU) IF (INU .GE. 0.0) GO TO 10 Z = CONJG(Z) NU = CONJG(NU) 10 X = REAL(Z) Y = AIMAG(Z) C C TANH(GAMMA) = SQRT(1 - (Z/NU)**2) = W/NU C T = EXP(NU*(TANH(GAMMA) - GAMMA)) C ZN = Z/NU IZN = AIMAG(ZN) IF (ABS(IZN) .GT. 0.1*ABS(REAL(ZN))) GO TO 20 C S = (1.0 - ZN)*(1.0 + ZN) ETA = 1.0/S Q = CSQRT(S) S = 1.0/(NU*Q) T = ZN/(1.0 + Q) T = CEXP(NU*(Q + CLOG(T))) GO TO 30 20 S = (NU - Z)*(NU + Z) ETA = (NU*NU)/S W = CSQRT(S) Q = W/NU IF (REAL(Q) .LT. 0.0) W = -W S = 1.0/W T = Z/(NU + W) T = CEXP(W + NU*CLOG(T)) C 30 IS = AIMAG(S) R = CSQRT(S) C1 = R*T AR = REAL(R)*REAL(R) + AIMAG(R)*AIMAG(R) AQ = -1.0/(REAL(Q)*REAL(Q) + AIMAG(Q)*AIMAG(Q)) C PHI = ATAN2(Y,X)/3.0 Q = NU - Z THETA = ATAN2(AIMAG(Q),REAL(Q)) - PHI IND = 0 IF (ABS(THETA) .LT. 2.0*BND) GO TO 50 C IND = 1 CALL CREC(REAL(T), AIMAG(T), U, V) C2 = -J*R*CMPLX(U, V) IF (IS .LT. 0.0) GO TO 40 IF (IS .GT. 0.0) GO TO 50 IF (REAL(S) .LE. 0.0) GO TO 50 40 C2 = -C2 C C SUMMATION OF THE SERIES S1 AND S2 C 50 SM = S*S P = (A(2)*ETA + A(3))*S P1 = ((A(4)*ETA + A(5))*ETA + A(6))*SM S1 = (1.0 + P) + P1 IF (IND .NE. 0) S2 = (1.0 - P) + P1 SGN = 1.0 AM = AR*AR M = 4 L = 6 C C P = VALUE OF THE M-TH POLYNOMIAL C 60 L = L + 1 ALPHA = A(L) P = CMPLX(A(L),0.0) DO 70 K = 2,M L = L + 1 ALPHA = A(L) + AQ*ALPHA P = A(L) + ETA*P 70 CONTINUE C C ONLY THE S1 SUM IS FORMED WHEN IND = 0 C SM = S*SM P = P*SM S1 = S1 + P IF (IND .EQ. 0) GO TO 80 SGN = -SGN S2 = S2 + SGN*P 80 AM = AR*AM IF (1.0 + ALPHA*AM .EQ. 1.0) GO TO 100 M = M + 1 IF (M .LE. 16) GO TO 60 C C FINAL ASSEMBLY C 100 S1 = C*C1*S1 IF (IND .NE. 0) GO TO 110 W = S1 GO TO 200 C 110 S2 = C*C2*S2 Q = NU + Z THETA = ATAN2(AIMAG(Q),REAL(Q)) - PHI IF (ABS(THETA) .GT. BND) GO TO 120 W = S1 + S2 GO TO 200 C 120 ALPHA = PI2 IF (IZN .LT. 0.0) ALPHA = -ALPHA T = ALPHA*CMPLX(ABS(INU), -FN) ALPHA = EXP(REAL(T)) U = AIMAG(T) R = CMPLX(COS(U),SIN(U)) T = S1 - (ALPHA*R)*S1 IF (X .EQ. 0.0 .AND. INU .EQ. 0.0) T = -T C IF (Y .GE. 0.0) GO TO 170 IF (IZN .GE. 0.0 .AND. THETA .LE. SIGN(PI,THETA)) * S2 = S2*(CONJG(R)/ALPHA) IF (X .EQ. 0.0) GO TO 180 IF (IZN .LT. 0.0) GO TO 170 IF (IS .LT. 0.0) GO TO 180 C 170 W = S2 + T GO TO 200 180 W = S2 - T C 200 IF (INU .LT. 0.0) W = CONJG(W) RETURN END SUBROUTINE CBJA (CZ, CNU, W) C----------------------------------------------------------------------- C COMPUTATION OF J(NU,Z) BY THE ASYMPTOTIC EXPANSION C----------------------------------------------------------------------- COMPLEX CZ, CNU, W REAL INU, M COMPLEX A, A1, ARG, E, ETA, J, NU, P, Q, T, Z, ZR, ZZ C-------------------------- ANORM(Z) = AMAX1(ABS(REAL(Z)), ABS(AIMAG(Z))) C-------------------------- C PIHALF = PI/2 C C = 2*PI**(-1/2) C-------------------------- DATA PIHALF /1.5707963267949/ DATA C /1.12837916709551/ DATA J /(0.0, 1.0)/ C-------------------------- C C ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE C SMALLEST NUMBER SUCH THAT 1.0 + EPS .GT. 1.0 . C EPS = SPMPAR(1) C C-------------------------- Z = CZ X = REAL(Z) Y = AIMAG(Z) NU = CNU IND = 0 IF (ABS(X) .GT. 1.E-2*ABS(Y)) GO TO 10 IF (AIMAG(NU) .GE. 0.0 .OR. ABS(REAL(NU)) .GE. * 1.E-2*ABS(AIMAG(NU))) GO TO 10 IND = 1 NU = CONJG(NU) Z = CONJG(Z) Y = -Y C 10 IF (X .LT. -1.E-2*Y) Z = -Z ZZ = Z + Z CALL CREC (REAL(ZZ), AIMAG(ZZ), U, V) ZR = CMPLX(U, V) ETA = -ZR*ZR C P = (0.0,0.0) Q = (0.0,0.0) A1 = NU*NU - 0.25 A = A1 T = A1 M = 1.0 TOL = EPS*ANORM(A1) DO 20 I = 1,16 A = A - 2.0*M M = M + 1.0 T = T*A*ETA/M P = P + T A = A - 2.0*M M = M + 1.0 T = T*A/M Q = Q + T IF (ANORM(T) .LE. TOL) GO TO 30 20 CONTINUE C 30 P = P + 1.0 Q = (Q + A1)*ZR W = Z - PIHALF*NU IF (ABS(AIMAG(W)) .GT. 1.0) GO TO 40 ARG = W - 0.5*PIHALF W = C*CSQRT(ZR)*(P*CCOS(ARG) - Q*CSIN(ARG)) GO TO 50 40 E = CEXP(-J*W) T = Q - J*P IF (AIMAG(Z) .GT. 0.0 .AND. REAL(Z) .LE. 1.E-2*AIMAG(Z) .AND. * ABS(REAL(NU)) .LT. 1.E-2*AIMAG(NU)) T = 0.5*T CALL CREC(REAL(E), AIMAG(E), U, V) W = 0.5*C*CSQRT(J*ZR)*((P - J*Q)*E + T*CMPLX(U, V)) C 50 IF (X .GE. -1.E-2*Y) GO TO 60 IF (Y .LT. 0.0) NU = -NU C C COMPUTATION OF EXP(I*PI*NU) C RNU = REAL(NU) INU = AIMAG(NU) R = EXP(-2.0*PIHALF*INU) U = R*COS1(RNU) V = R*SIN1(RNU) W = W*CMPLX(U,V) C 60 IF (IND .NE. 0) W = CONJG(W) RETURN END SUBROUTINE BSSLJ (A, IN, W) C ****************************************************************** C FORTRAN SUBROUTINE FOR ORDINARY BESSEL FUNCTION OF INTEGRAL ORDER C ****************************************************************** C A = ARGUMENT (COMPLEX NUMBER) C IN = ORDER (INTEGER) C W = FUNCTION OF FIRST KIND (COMPLEX NUMBER) C ------------------- COMPLEX A, W DIMENSION AZ(2), FJ(2) DIMENSION CD(30), CE(30) DIMENSION QZ(2), RZ(2), SZ(2), ZR(2) DIMENSION TS(2), TM(2), RM(4), SM(4), AQ(2), QF(2) DATA CD(1) / 0.00000000000000E00/, CD(2) /-1.64899505142212E-2/, 1 CD(3) /-7.18621880068536E-2/, CD(4) /-1.67086878124866E-1/, 2 CD(5) /-3.02582250219469E-1/, CD(6) /-4.80613945245927E-1/, 3 CD(7) /-7.07075239357898E-1/, CD(8) /-9.92995790539516E-1/, 4 CD(9) /-1.35583925612592E00/, CD(10)/-1.82105907899132E00/, 5 CD(11)/-2.42482175310879E00/, CD(12)/-3.21956655708750E00/, 6 CD(13)/-4.28658077248384E00/, CD(14)/-5.77022816798128E00/, 7 CD(15)/-8.01371260952526E00/ DATA CD(16)/ 0.00000000000000E00/, CD(17)/-5.57742429879505E-3/, 1 CD(18)/-4.99112944172476E-2/, CD(19)/-1.37440911652397E-1/, 2 CD(20)/-2.67233784710566E-1/, CD(21)/-4.40380166808682E-1/, 3 CD(22)/-6.61813614872541E-1/, CD(23)/-9.41861077665017E-1/, 4 CD(24)/-1.29754130468326E00/, CD(25)/-1.75407696719816E00/, 5 CD(26)/-2.34755299882276E00/, CD(27)/-3.13041332689196E00/, 6 CD(28)/-4.18397120563729E00/, CD(29)/-5.65251799214994E00/, 7 CD(30)/-7.87863959810677E00/ DATA CE(1) / 0.00000000000000E00/, CE(2) /-4.80942336387447E-3/, 1 CE(3) /-1.31366200347759E-2/, CE(4) /-1.94843834008458E-2/, 2 CE(5) /-2.19948900032003E-2/, CE(6) /-2.09396625676519E-2/, 3 CE(7) /-1.74600268458650E-2/, CE(8) /-1.27937813362085E-2/, 4 CE(9) /-8.05234421796592E-3/, CE(10)/-4.15817375002760E-3/, 5 CE(11)/-1.64317738747922E-3/, CE(12)/-4.49175585314709E-4/, 6 CE(13)/-7.28594765574007E-5/, CE(14)/-5.38265230658285E-6/, 7 CE(15)/-9.93779048036289E-8/ DATA CE(16)/ 0.00000000000000E00/, CE(17)/ 7.53805779200591E-2/, 1 CE(18)/ 7.12293537403464E-2/, CE(19)/ 6.33116224228200E-2/, 2 CE(20)/ 5.28240264523301E-2/, CE(21)/ 4.13305359441492E-2/, 3 CE(22)/ 3.01350573947510E-2/, CE(23)/ 2.01043439592720E-2/, 4 CE(24)/ 1.18552223068074E-2/, CE(25)/ 5.86055510956010E-3/, 5 CE(26)/ 2.25465148267325E-3/, CE(27)/ 6.08173041536336E-4/, 6 CE(28)/ 9.84215550625747E-5/, CE(29)/ 7.32139093038089E-6/, 7 CE(30)/ 1.37279667384666E-7/ C ------------------- AZ(1)=REAL(A) AZ(2)=AIMAG(A) ZS=AZ(1)*AZ(1)+AZ(2)*AZ(2) ZM=SQRT(ZS) PN=IABS(IN) SN=+1.0 IF(IN)002,003,003 002 IF(IN.EQ.IN/2*2)GO TO 003 SN=-1.0 003 IF(AZ(1))004,005,005 004 QZ(1)=-AZ(1) QZ(2)=-AZ(2) IF(IN.EQ.IN/2*2)GO TO 006 SN=-SN GO TO 006 005 QZ(1)=+AZ(1) QZ(2)=+AZ(2) 006 IF(ZM.LE.17.5+0.5*PN*PN)GO TO 007 QN=PN GO TO 013 007 QN=0.5*ZM-0.5*ABS(QZ(2))+0.5*ABS(0.5*ZM-ABS(QZ(2))) IF(PN.LE.QN)GO TO 008 QN=+AINT(0.0625*ZS) IF(PN.LE.QN)GO TO 031 QN=PN GO TO 031 008 IF(ZM.LE.17.5)GO TO 009 QN=+AINT(SQRT(2.0*(ZM-17.5))) GO TO 013 009 IF(ZS-1.0)011,010,010 010 IF(-ABS(AZ(2))+0.096*AZ(1)*AZ(1))011,012,012 011 QN=+AINT(0.0625*ZS) IF(PN.LE.QN)GO TO 031 QN=PN GO TO 031 012 QN=0.0 013 SZ(1)=QZ(1) SZ(2)=QZ(2) QM=SN*0.797884560802865 ZR(1)=SQRT(SZ(1)+ZM) ZR(2)=SZ(2)/ZR(1) ZR(1)=0.707106781186548*ZR(1) ZR(2)=0.707106781186548*ZR(2) QF(1)=+QM*ZR(1)/ZM QF(2)=-QM*ZR(2)/ZM IF(ZM.LE.17.5)GO TO 018 014 RZ(1)=+0.5*QZ(1)/ZS RZ(2)=-0.5*QZ(2)/ZS AN=QN*QN-0.25 SM(1)=0.0 SM(2)=0.0 SM(3)=0.0 SM(4)=0.0 TM(1)=1.0 TM(2)=0.0 PM=0.0 GO TO 016 015 AN=AN-2.0*PM PM=PM+1.0 TS(1)=TM(1)*RZ(1)-TM(2)*RZ(2) TS(2)=TM(1)*RZ(2)+TM(2)*RZ(1) TM(1)=-AN*TS(1)/PM TM(2)=-AN*TS(2)/PM 016 SM(1)=SM(1)+TM(1) SM(2)=SM(2)+TM(2) AN=AN-2.0*PM PM=PM+1.0 TS(1)=TM(1)*RZ(1)-TM(2)*RZ(2) TS(2)=TM(1)*RZ(2)+TM(2)*RZ(1) TM(1)=+AN*TS(1)/PM TM(2)=+AN*TS(2)/PM IF(ABS(SM(3))+ABS(TM(1)).NE.ABS(SM(3)))GO TO 017 IF(ABS(SM(4))+ABS(TM(2)).EQ.ABS(SM(4)))GO TO 020 017 SM(3)=SM(3)+TM(1) SM(4)=SM(4)+TM(2) IF(PM.LT.35.0)GO TO 015 GO TO 020 018 SM(1)=1.0 SM(2)=0.0 SM(3)=1.0 SM(4)=0.0 M=15.0*QN+2.0 N=15.0*QN+15.0 DO 019 I=M,N TS(1)=+QZ(2)-CD(I) TS(2)=-QZ(1) SS=TS(1)*TS(1)+TS(2)*TS(2) TM(1)=+CE(I)*TS(1)/SS TM(2)=-CE(I)*TS(2)/SS SM(1)=SM(1)+TM(1) SM(2)=SM(2)+TM(2) TS(1)=-QZ(2)-CD(I) TS(2)=+QZ(1) SS=TS(1)*TS(1)+TS(2)*TS(2) TM(1)=+CE(I)*TS(1)/SS TM(2)=-CE(I)*TS(2)/SS SM(3)=SM(3)+TM(1) SM(4)=SM(4)+TM(2) 019 CONTINUE TS(1)=+0.5*(SM(2)-SM(4)) TS(2)=-0.5*(SM(1)-SM(3)) SM(1)=+0.5*(SM(1)+SM(3)) SM(2)=+0.5*(SM(2)+SM(4)) SM(3)=TS(1) SM(4)=TS(2) 020 AQ(1)=QZ(1)-1.57079632679490*(QN+0.5) AQ(2)=QZ(2) TS(1)=+COS(AQ(1))*0.5*(EXP(+AQ(2))+EXP(-AQ(2))) TS(2)=-SIN(AQ(1))*0.5*(EXP(+AQ(2))-EXP(-AQ(2))) TM(1)=SM(1)*TS(1)-SM(2)*TS(2) TM(2)=SM(1)*TS(2)+SM(2)*TS(1) TS(1)=+SIN(AQ(1))*0.5*(EXP(+AQ(2))+EXP(-AQ(2))) TS(2)=+COS(AQ(1))*0.5*(EXP(+AQ(2))-EXP(-AQ(2))) RM(1)=TM(1)-SM(3)*TS(1)+SM(4)*TS(2) RM(2)=TM(2)-SM(3)*TS(2)-SM(4)*TS(1) IF(QN.EQ.PN)GO TO 030 RM(3)=RM(1) RM(4)=RM(2) QN=QN+1.0 IF(ZM.LE.17.5)GO TO 025 021 AN=QN*QN-0.25 SM(1)=0.0 SM(2)=0.0 SM(3)=0.0 SM(4)=0.0 TM(1)=1.0 TM(2)=0.0 PM=0.0 GO TO 023 022 AN=AN-2.0*PM PM=PM+1.0 TS(1)=TM(1)*RZ(1)-TM(2)*RZ(2) TS(2)=TM(1)*RZ(2)+TM(2)*RZ(1) TM(1)=-AN*TS(1)/PM TM(2)=-AN*TS(2)/PM 023 SM(1)=SM(1)+TM(1) SM(2)=SM(2)+TM(2) AN=AN-2.0*PM PM=PM+1.0 TS(1)=TM(1)*RZ(1)-TM(2)*RZ(2) TS(2)=TM(1)*RZ(2)+TM(2)*RZ(1) TM(1)=+AN*TS(1)/PM TM(2)=+AN*TS(2)/PM IF(ABS(SM(3))+ABS(TM(1)).NE.ABS(SM(3)))GO TO 024 IF(ABS(SM(4))+ABS(TM(2)).EQ.ABS(SM(4)))GO TO 027 024 SM(3)=SM(3)+TM(1) SM(4)=SM(4)+TM(2) IF(PM.LT.35.0)GO TO 022 GO TO 027 025 SM(1)=1.0 SM(2)=0.0 SM(3)=1.0 SM(4)=0.0 M=15.0*QN+2.0 N=15.0*QN+15.0 DO 026 I=M,N TS(1)=+QZ(2)-CD(I) TS(2)=-QZ(1) SS=TS(1)*TS(1)+TS(2)*TS(2) TM(1)=+CE(I)*TS(1)/SS TM(2)=-CE(I)*TS(2)/SS SM(1)=SM(1)+TM(1) SM(2)=SM(2)+TM(2) TS(1)=-QZ(2)-CD(I) TS(2)=+QZ(1) SS=TS(1)*TS(1)+TS(2)*TS(2) TM(1)=+CE(I)*TS(1)/SS TM(2)=-CE(I)*TS(2)/SS SM(3)=SM(3)+TM(1) SM(4)=SM(4)+TM(2) 026 CONTINUE TS(1)=+0.5*(SM(2)-SM(4)) TS(2)=-0.5*(SM(1)-SM(3)) SM(1)=+0.5*(SM(1)+SM(3)) SM(2)=+0.5*(SM(2)+SM(4)) SM(3)=TS(1) SM(4)=TS(2) 027 AQ(1)=QZ(1)-1.57079632679490*(QN+0.5) AQ(2)=QZ(2) TS(1)=+COS(AQ(1))*0.5*(EXP(+AQ(2))+EXP(-AQ(2))) TS(2)=-SIN(AQ(1))*0.5*(EXP(+AQ(2))-EXP(-AQ(2))) TM(1)=SM(1)*TS(1)-SM(2)*TS(2) TM(2)=SM(1)*TS(2)+SM(2)*TS(1) TS(1)=+SIN(AQ(1))*0.5*(EXP(+AQ(2))+EXP(-AQ(2))) TS(2)=+COS(AQ(1))*0.5*(EXP(+AQ(2))-EXP(-AQ(2))) RM(1)=TM(1)-SM(3)*TS(1)+SM(4)*TS(2) RM(2)=TM(2)-SM(3)*TS(2)-SM(4)*TS(1) GO TO 029 028 TM(1)=+2.0*QN*QZ(1)/ZS TM(2)=-2.0*QN*QZ(2)/ZS TS(1)=TM(1)*RM(1)-TM(2)*RM(2)-RM(3) TS(2)=TM(1)*RM(2)+TM(2)*RM(1)-RM(4) RM(3)=RM(1) RM(4)=RM(2) RM(1)=TS(1) RM(2)=TS(2) QN=QN+1.0 029 IF(QN.LT.PN)GO TO 028 030 FJ(1)=QF(1)*RM(1)-QF(2)*RM(2) FJ(2)=QF(1)*RM(2)+QF(2)*RM(1) W=CMPLX(FJ(1),FJ(2)) RETURN 031 SZ(1)=+0.25*(QZ(1)*QZ(1)-QZ(2)*QZ(2)) SZ(2)=+0.5*QZ(1)*QZ(2) AN=QN SM(1)=0.0 SM(2)=0.0 SM(3)=0.0 SM(4)=0.0 TM(1)=1.0 TM(2)=0.0 PM=0.0 032 AN=AN+1.0 TS(1)=+TM(1)/AN TS(2)=+TM(2)/AN SM(3)=SM(3)+TS(1) SM(4)=SM(4)+TS(2) TM(1)=-TS(1)*SZ(1)+TS(2)*SZ(2) TM(2)=-TS(1)*SZ(2)-TS(2)*SZ(1) PM=PM+1.0 TM(1)=TM(1)/PM TM(2)=TM(2)/PM IF(ABS(SM(1))+ABS(TM(1)).NE.ABS(SM(1)))GO TO 033 IF(ABS(SM(2))+ABS(TM(2)).EQ.ABS(SM(2)))GO TO 034 033 SM(1)=SM(1)+TM(1) SM(2)=SM(2)+TM(2) GO TO 032 034 SM(1)=SM(1)+1.0 AN=QN+1.0 SM(3)=AN*SM(3) SM(4)=AN*SM(4) GO TO 036 035 AN=QN*(QN+1.0) TM(1)=SZ(1)/AN TM(2)=SZ(2)/AN TS(1)=-TM(1)*SM(3)+TM(2)*SM(4) TS(2)=-TM(1)*SM(4)-TM(2)*SM(3) SM(3)=SM(1) SM(4)=SM(2) SM(1)=SM(1)+TS(1) SM(2)=SM(2)+TS(2) QN=QN-1.0 036 IF(QN.GT.PN)GO TO 035 QF(1)=SN QF(2)=0.0 QN=0.0 GO TO 038 037 QN=QN+1.0 TM(1)=QF(1)*QZ(1)-QF(2)*QZ(2) TM(2)=QF(1)*QZ(2)+QF(2)*QZ(1) QF(1)=0.5*TM(1)/QN QF(2)=0.5*TM(2)/QN 038 IF(QN.LT.PN)GO TO 037 FJ(1)=QF(1)*SM(1)-QF(2)*SM(2) FJ(2)=QF(1)*SM(2)+QF(2)*SM(1) W=CMPLX(FJ(1),FJ(2)) RETURN END SUBROUTINE BESJ(X, ALPHA, N, Y, NZ) C C WRITTEN BY D.E. AMOS, S.L. DANIEL AND M.K. WESTON, JANUARY, 1975. C C REFERENCES C SAND-75-0147 C C CDC 6600 SUBROUTINES IBESS AND JBESS FOR BESSEL FUNCTIONS C I(NU,X) AND J(NU,X), X.GE.0, NU.GE.0 BY D.E. AMOS, S.L. C DANIEL, M.K. WESTON. ACM TRANS MATH SOFTWARE,3,PP 76-92 C (1977) C C TABLES OF BESSEL FUNCTIONS OF MODERATE OR LARGE ORDERS, C NPL MATHEMATICAL TABLES, VOL. 6, BY F.W.J. OLVER, HER C MAJESTY-S STATIONERY OFFICE, LONDON, 1962. C C ABSTRACT C BESJ COMPUTES AN N MEMBER SEQUENCE OF J BESSEL FUNCTIONS C J/SUB(ALPHA+K-1)/(X), K=1,...,N FOR NON-NEGATIVE ALPHA AND X. C A COMBINATION OF THE POWER SERIES, THE ASYMPTOTIC EXPANSION C FOR X TO INFINITY AND THE UNIFORM ASYMPTOTIC EXPANSION FOR C NU TO INFINITY ARE APPLIED OVER SUBDIVISIONS OF THE (NU,X) C PLANE. FOR VALUES OF (NU,X) NOT COVERED BY ONE OF THESE C FORMULAE, THE ORDER IS INCREMENTED OR DECREMENTED BY INTEGER C VALUES INTO A REGION WHERE ONE OF THE FORMULAE APPLY. BACKWARD C RECURSION IS APPLIED TO REDUCE ORDERS BY INTEGER VALUES EXCEPT C WHERE THE ENTIRE SEQUENCE LIES IN THE OSCILLATORY REGION. IN C THIS CASE FORWARD RECURSION IS STABLE AND VALUES FROM THE C ASYMPTOTIC EXPANSION FOR X TO INFINITY START THE RECURSION C WHEN IT IS EFFICIENT TO DO SO. LEADING TERMS OF THE SERIES AND C UNIFORM EXPANSION ARE TESTED FOR UNDERFLOW. IF A SEQUENCE IS C REQUESTED AND THE LAST MEMBER WOULD UNDERFLOW, THE RESULT IS C SET TO ZERO AND THE NEXT LOWER ORDER TRIED, ETC., UNTIL A C MEMBER COMES ON SCALE OR ALL MEMBERS ARE SET TO ZERO. OVERFLOW C CANNOT OCCUR. C C BESJ CALLS ASJY, JAIRY, GAMLN, SPMPAR, AND IPMPAR C C DESCRIPTION OF ARGUMENTS C C INPUT C X - X.GE.0.0E0 C ALPHA - ORDER OF FIRST MEMBER OF THE SEQUENCE, C ALPHA.GE.0.0E0 C N - NUMBER OF MEMBERS IN THE SEQUENCE, N.GE.1 C C OUTPUT C Y - A VECTOR WHOSE FIRST N COMPONENTS CONTAIN C VALUES FOR J/SUB(ALPHA+K-1)/(X), K=1,...,N C NZ - ERROR INDICATOR C NZ=0 NORMAL RETURN - COMPUTATION COMPLETED C NZ=-1 X IS LESS THAN 0.0 C NZ=-2 ALPHA IS LESS THAN 0.0 C NZ=-3 N IS LESS THAN 1 C NZ.GT.0 LAST NZ COMPONENTS OF Y SET TO 0.0 C BECAUSE OF UNDERFLOW C C ERROR CONDITIONS C IMPROPER INPUT ARGUMENTS - A FATAL ERROR C UNDERFLOW - A NON-FATAL ERROR (NZ.GT.0) C EXTERNAL JAIRY INTEGER I,IALP,IDALP,IFLW,IN,INLIM,IS,I1,I2,K,KK,KM,KT,N,NN, 1 NS,NZ INTEGER IPMPAR REAL AK,AKM,ALPHA,ANS,AP,ARG,COEF,DALPHA,DFN,DTM,EARG, 1 ELIM,ETX,FIDAL,FLGJY,FN,FNF,FNI,FNP1,FNU,FNULIM, 2 GLN,PDF,PIDT,PP,RDEN,RELB,RTTP,RTWO,RTX,RZDEN, 3 S,SA,SB,SXO2,S1,S2,T,TA,TAU,TB,TEMP,TFN,TM,TOL, 4 TOLLN,TRX,TX,T1,T2,WK,X,XO2,XO2L,Y REAL GAMLN, SPMPAR DIMENSION Y(N), TEMP(3), FNULIM(2), PP(4), WK(7) DATA RTWO,PDF,RTTP,PIDT / 1.34839972492648E+00, 1 7.85398163397448E-01, 7.97884560802865E-01, 1.57079632679490E+00/ DATA PP(1), PP(2), PP(3), PP(4) / 8.72909153935547E+00, 1 2.65693932265030E-01, 1.24578576865586E-01, 7.70133747430388E-04/ DATA INLIM / 150 / DATA FNULIM(1), FNULIM(2) / 100.0E0, 60.0E0 / C ------------------- C IPMPAR(8) REPLACES IPMPAR(5) IN A DOUBLE PRECISION CODE C IPMPAR(9) REPLACES IPMPAR(6) IN A DOUBLE PRECISION CODE C C DEFINITION OF THE TOLERANCES TOL AND ELIM C TB = IPMPAR(4) TA = SPMPAR(1)/TB IF (TB.EQ.2.0E0) GO TO 1 IF (TB.EQ.8.0E0) GO TO 2 IF (TB.EQ.16.0E0) GO TO 3 TB = ALOG(TB) GO TO 5 1 TB = .69315E0 GO TO 5 2 TB = 2.07944E0 GO TO 5 3 TB = 2.77259E0 C 5 TOL = AMAX1(TA,1.E-15) I1 = IPMPAR(5) I2 = IPMPAR(6) C LN(10**3) = 6.90776 ELIM = FLOAT(-I2)*TB - 6.90776E0 C TOLLN = -LN(TOL) TOLLN = FLOAT(I1)*TB TOLLN = AMIN1(TOLLN,34.5388E0) C C C NZ = 0 KT = 1 IF (N-1) 720, 10, 20 10 KT = 2 20 NN = N IF (X) 730, 30, 80 30 IF (ALPHA) 710, 40, 50 40 Y(1) = 1.0E0 IF (N.EQ.1) RETURN I1 = 2 GO TO 60 50 I1 = 1 60 DO 70 I=I1,N Y(I) = 0.0E0 70 CONTINUE RETURN 80 CONTINUE IF (ALPHA.LT.0.0E0) GO TO 710 C IALP = INT(ALPHA) FNI = FLOAT(IALP+N-1) FNF = ALPHA - FLOAT(IALP) DFN = FNI + FNF FNU = DFN XO2 = X*0.5E0 SXO2 = XO2*XO2 C C DECISION TREE FOR REGION WHERE SERIES, ASYMPTOTIC EXPANSION FOR X C TO INFINITY AND ASYMPTOTIC EXPANSION FOR NU TO INFINITY ARE C APPLIED. C IF (SXO2.LE.(FNU+1.0E0)) GO TO 90 TA = AMAX1(20.0E0,FNU) IF (X.GT.TA) GO TO 120 IF (X.GT.12.0E0) GO TO 110 XO2L = ALOG(XO2) NS = INT(SXO2-FNU) + 1 GO TO 100 90 FN = FNU FNP1 = FN + 1.0E0 XO2L = ALOG(XO2) IS = KT IF (X.LE.0.50E0) GO TO 330 NS = 0 100 FNI = FNI + FLOAT(NS) DFN = FNI + FNF FN = DFN FNP1 = FN + 1.0E0 IS = KT IF (N-1+NS.GT.0) IS = 3 GO TO 330 110 ANS = AMAX1(36.0E0-FNU,0.0E0) NS = INT(ANS) FNI = FNI + FLOAT(NS) DFN = FNI + FNF FN = DFN IS = KT IF (N-1+NS.GT.0) IS = 3 GO TO 130 120 CONTINUE RTX = SQRT(X) TAU = RTWO*RTX TA = TAU + FNULIM(KT) IF (FNU.LE.TA) GO TO 480 FN = FNU IS = KT C C UNIFORM ASYMPTOTIC EXPANSION FOR NU TO INFINITY C 130 CONTINUE I1 = IABS(3-IS) I1 = MAX0(I1,1) FLGJY = 1.0E0 CALL ASJY(JAIRY,X,FN,FLGJY,I1,TOL,ELIM,TEMP(IS),WK,IFLW) IF(IFLW.NE.0) GO TO 380 GO TO (320, 450, 620), IS 310 TEMP(1) = TEMP(3) KT = 1 320 IS = 2 FNI = FNI - 1.0E0 DFN = FNI + FNF FN = DFN IF(I1.EQ.2) GO TO 450 GO TO 130 C C SERIES FOR (X/2)**2.LE.NU+1 C 330 CONTINUE GLN = GAMLN(FNP1) ARG = FN*XO2L - GLN IF (ARG.LT.(-ELIM)) GO TO 400 EARG = EXP(ARG) 340 CONTINUE S = 1.0E0 IF (X.LT.TOL) GO TO 360 AK = 3.0E0 T2 = 1.0E0 T = 1.0E0 S1 = FN DO 350 K=1,17 S2 = T2 + S1 T = -T*SXO2/S2 S = S + T IF (ABS(T).LT.TOL) GO TO 360 T2 = T2 + AK AK = AK + 2.0E0 S1 = S1 + FN 350 CONTINUE 360 CONTINUE TEMP(IS) = S*EARG GO TO (370, 450, 610), IS 370 EARG = EARG*FN/XO2 FNI = FNI - 1.0E0 DFN = FNI + FNF FN = DFN IS = 2 GO TO 340 C C SET UNDERFLOW VALUE AND UPDATE PARAMETERS C 380 Y(NN) = 0.0E0 NN = NN - 1 FNI = FNI - 1.0E0 DFN = FNI + FNF FN = DFN IF (NN-1) 440, 390, 130 390 KT = 2 IS = 2 GO TO 130 400 Y(NN) = 0.0E0 NN = NN - 1 FNP1 = FN FNI = FNI - 1.0E0 DFN = FNI + FNF FN = DFN IF (NN-1) 440, 410, 420 410 KT = 2 IS = 2 420 IF (SXO2.LE.FNP1) GO TO 430 GO TO 130 430 ARG = ARG - XO2L + ALOG(FNP1) IF (ARG.LT.(-ELIM)) GO TO 400 GO TO 330 440 NZ = N - NN RETURN C C BACKWARD RECURSION SECTION C 450 CONTINUE NZ = N - NN IF (KT.EQ.2) GO TO 470 C BACKWARD RECUR FROM INDEX ALPHA+NN-1 TO ALPHA Y(NN) = TEMP(1) Y(NN-1) = TEMP(2) IF (NN.EQ.2) RETURN TRX = 2.0E0/X DTM = FNI TM = (DTM+FNF)*TRX K = NN + 1 DO 460 I=3,NN K = K - 1 Y(K-2) = TM*Y(K-1) - Y(K) DTM = DTM - 1.0E0 TM = (DTM+FNF)*TRX 460 CONTINUE RETURN 470 Y(1) = TEMP(2) RETURN C C ASYMPTOTIC EXPANSION FOR X TO INFINITY WITH FORWARD RECURSION IN C OSCILLATORY REGION X.GT.MAX(20, NU), PROVIDED THE LAST MEMBER C OF THE SEQUENCE IS ALSO IN THE REGION. C 480 CONTINUE IN = INT(ALPHA-TAU+2.0E0) IF (IN.LE.0) GO TO 490 IDALP = IALP - IN - 1 KT = 1 GO TO 500 490 CONTINUE IDALP = IALP IN = 0 500 IS = KT FIDAL = FLOAT(IDALP) DALPHA = FIDAL + FNF ARG = X - PIDT*DALPHA - PDF SA = SIN(ARG) SB = COS(ARG) COEF = RTTP/RTX ETX = 8.0E0*X 510 CONTINUE DTM = FIDAL + FIDAL DTM = DTM*DTM TM = 0.0E0 IF (FIDAL.EQ.0.0E0 .AND. ABS(FNF).LT.TOL) GO TO 520 TM = 4.0E0*FNF*(FIDAL+FIDAL+FNF) 520 CONTINUE TRX = DTM - 1.0E0 T2 = (TRX+TM)/ETX S2 = T2 RELB = TOL*ABS(T2) T1 = ETX S1 = 1.0E0 FN = 1.0E0 AK = 8.0E0 DO 530 K=1,13 T1 = T1 + ETX FN = FN + AK TRX = DTM - FN AP = TRX + TM T2 = -T2*AP/T1 S1 = S1 + T2 T1 = T1 + ETX AK = AK + 8.0E0 FN = FN + AK TRX = DTM - FN AP = TRX + TM T2 = T2*AP/T1 S2 = S2 + T2 IF (ABS(T2).LE.RELB) GO TO 540 AK = AK + 8.0E0 530 CONTINUE 540 TEMP(IS) = COEF*(S1*SB-S2*SA) IF(IS.EQ.2) GO TO 560 550 FIDAL = FIDAL + 1.0E0 DALPHA = FIDAL + FNF IS = 2 TB = SA SA = -SB SB = TB GO TO 510 C C FORWARD RECURSION SECTION C 560 IF (KT.EQ.2) GO TO 470 S1 = TEMP(1) S2 = TEMP(2) TX = 2.0E0/X TM = DALPHA*TX IF (IN.EQ.0) GO TO 580 C C FORWARD RECUR TO INDEX ALPHA C DO 570 I=1,IN S = S2 S2 = TM*S2 - S1 TM = TM + TX S1 = S 570 CONTINUE IF (NN.EQ.1) GO TO 600 S = S2 S2 = TM*S2 - S1 TM = TM + TX S1 = S 580 CONTINUE C C FORWARD RECUR FROM INDEX ALPHA TO ALPHA+N-1 C Y(1) = S1 Y(2) = S2 IF (NN.EQ.2) RETURN DO 590 I=3,NN Y(I) = TM*Y(I-1) - Y(I-2) TM = TM + TX 590 CONTINUE RETURN 600 Y(1) = S2 RETURN C C BACKWARD RECURSION WITH NORMALIZATION BY C ASYMPTOTIC EXPANSION FOR NU TO INFINITY OR POWER SERIES. C 610 CONTINUE C COMPUTATION OF LAST ORDER FOR SERIES NORMALIZATION AKM = AMAX1(3.0E0-FN,0.0E0) KM = INT(AKM) TFN = FN + FLOAT(KM) TA = (GLN+TFN-0.9189385332E0-0.0833333333E0/TFN)/(TFN+0.5E0) TA = XO2L - TA TB = -(1.0E0-1.5E0/TFN)/TFN AKM = TOLLN/(-TA+SQRT(TA*TA-TOLLN*TB)) + 1.5E0 IN = KM + INT(AKM) GO TO 660 620 CONTINUE C COMPUTATION OF LAST ORDER FOR ASYMPTOTIC EXPANSION NORMALIZATION GLN = WK(3) + WK(2) IF (WK(6).GT.30.0E0) GO TO 640 RDEN = (PP(4)*WK(6)+PP(3))*WK(6) + 1.0E0 RZDEN = PP(1) + PP(2)*WK(6) TA = RZDEN/RDEN IF (WK(1).LT.0.10E0) GO TO 630 TB = GLN/WK(5) GO TO 650 630 TB=(1.259921049E0+(0.1679894730E0+0.0887944358E0*WK(1))*WK(1)) 1 /WK(7) GO TO 650 640 CONTINUE TA = 0.5E0*TOLLN/WK(4) TA=((0.0493827160E0*TA-0.1111111111E0)*TA+0.6666666667E0)*TA*WK(6) IF (WK(1).LT.0.10E0) GO TO 630 TB = GLN/WK(5) 650 IN = INT(TA/TB+1.5E0) IF (IN.GT.INLIM) GO TO 310 660 CONTINUE DTM = FNI + FLOAT(IN) TRX = 2.0E0/X TM = (DTM+FNF)*TRX TA = 0.0E0 TB = TOL KK = 1 670 CONTINUE C C BACKWARD RECUR UNINDEXED C DO 680 I=1,IN S = TB TB = TM*TB - TA TA = S DTM = DTM - 1.0E0 TM = (DTM+FNF)*TRX 680 CONTINUE C NORMALIZATION IF (KK.NE.1) GO TO 690 TA = (TA/TB)*TEMP(3) TB = TEMP(3) KK = 2 IN = NS IF (NS.NE.0) GO TO 670 690 Y(NN) = TB NZ = N - NN IF (NN.EQ.1) RETURN K = NN - 1 Y(K) = TM*TB - TA IF (NN.EQ.2) RETURN DTM = DTM - 1.0E0 TM = (DTM+FNF)*TRX KM = K - 1 C C BACKWARD RECUR INDEXED C DO 700 I=1,KM Y(K-1) = TM*Y(K) - Y(K+1) DTM = DTM - 1.0E0 TM = (DTM+FNF)*TRX K = K - 1 700 CONTINUE RETURN C C C 710 CONTINUE NZ = -2 RETURN 720 CONTINUE NZ = -3 RETURN 730 CONTINUE NZ = -1 RETURN END SUBROUTINE ASJY(FUNJY,X,FNU,FLGJY,IN,TOL,ELIM,Y,WK,IFLW) C C ASJY COMPUTES BESSEL FUNCTIONS J AND Y C FOR ARGUMENTS X.GT.0.0 AND ORDERS FNU.GE.35.0 C ON FLGJY = 1 AND FLGJY = -1 RESPECTIVELY C C INPUT C C FUNJY - EXTERNAL FUNCTION JAIRY OR YAIRY C X - ARGUMENT, X.GT.0.0E0 C FNU - ORDER OF THE FIRST BESSEL FUNCTION C FLGJY - SELECTION FLAG C FLGJY = 1.0E0 GIVES THE J FUNCTION C FLGJY = -1.0E0 GIVES THE Y FUNCTION C IN - NUMBER OF FUNCTIONS DESIRED, IN = 1 OR 2 C TOL - TOLERANCE SPECIFIED BY BESJ OR BESY C ELIM - TOLERANCE SPECIFIED BY BESJ OR BESY C C OUTPUT C C Y - A VECTOR WHOSE FIRST IN COMPONENTS CONTAIN THE SEQUENCE C IFLW - A FLAG INDICATING UNDERFLOW OR OVERFLOW C RETURN VARIABLES FOR BESJ ONLY C WK(1) = 1 - (X/FNU)**2 = W**2 C WK(2) = SQRT(ABS(WK(1))) C WK(3) = ABS(WK(2) - ATAN(WK(2))) OR C ABS(LN((1 + WK(2))/(X/FNU)) - WK(2)) C = ABS((2/3)*ZETA**(3/2)) C WK(4) = FNU*WK(3) C WK(5) = (1.5*WK(3)*FNU)**(1/3) = SQRT(ZETA)*FNU**(1/3) C WK(6) = SIGN(1.,W**2)*WK(5)**2 = SIGN(1.,W**2)*ZETA*FNU**(2/3) C WK(7) = FNU**(1/3) C C WRITTEN BY C D. E. AMOS C C ABSTRACT C ASJK IMPLEMENTS THE UNIFORM ASYMPTOTIC EXPANSION OF C THE J AND Y BESSEL FUNCTIONS FOR FNU.GE.35 AND REAL C X.GT.0.0E0. THE FORMS ARE IDENTICAL EXCEPT FOR A CHANGE C IN SIGN OF SOME OF THE TERMS. THIS CHANGE IN SIGN IS C ACCOMPLISHED BY MEANS OF THE FLAG FLGJY = 1 OR -1. ON C FLGJY = 1 THE AIRY FUNCTIONS AI(X) AND DAI(X) ARE C SUPPLIED BY THE EXTERNAL FUNCTION JAIRY, AND ON C FLGJY = -1 THE AIRY FUNCTIONS BI(X) AND DBI(X) ARE C SUPPLIED BY THE EXTERNAL FUNTION YAIRY. C INTEGER I, IFLW, IN, J, JN,JR,JU,K, KB,KLAST,KMAX,KP1, KS, KSP1, * KSTEMP, L, LR, LRP1 REAL ABW2, AKM, ALFA, ALFA1, ALFA2, AP, AR, ASUM, AZ, * BETA, BETA1, BETA2, BETA3, BR, BSUM, C, CON1, CON2, * CON3,CON548,CR,CRZ32, DFI,ELIM, DR,FI, FLGJY, FN, FNU, * FN2, GAMA, PHI, RCZ, RDEN, RELB, RFN2, RTZ, RZDEN, * SA, SB, SUMA, SUMB, S1, TA, TAU, TB, TFN, TOL, TOLS, T2, UPOL, * WK, X, XX, Y, Z, Z32 EXTERNAL FUNJY DIMENSION Y(*), WK(*), C(65) DIMENSION ALFA(26,4), BETA(26,5) DIMENSION ALFA1(26,2), ALFA2(26,2) DIMENSION BETA1(26,2), BETA2(26,2), BETA3(26,1) DIMENSION GAMA(26), KMAX(5), AR(8), BR(10), UPOL(10) DIMENSION CR(10), DR(10) EQUIVALENCE (ALFA(1,1),ALFA1(1,1)) EQUIVALENCE (ALFA(1,3),ALFA2(1,1)) EQUIVALENCE (BETA(1,1),BETA1(1,1)) EQUIVALENCE (BETA(1,3),BETA2(1,1)) EQUIVALENCE (BETA(1,5),BETA3(1,1)) DATA TOLS /-6.90775527898214E+00/ DATA CON1,CON2,CON3,CON548/ 1 6.66666666666667E-01, 3.33333333333333E-01, 1.41421356237310E+00, 2 1.04166666666667E-01/ DATA AR(1), AR(2), AR(3), AR(4), AR(5), AR(6), AR(7), A AR(8) / 8.35503472222222E-02, 1.28226574556327E-01, 1 2.91849026464140E-01, 8.81627267443758E-01, 3.32140828186277E+00, 2 1.49957629868626E+01, 7.89230130115865E+01, 4.74451538868264E+02/ DATA BR(1), BR(2), BR(3), BR(4), BR(5), BR(6), BR(7), BR(8), A BR(9), BR(10) /-1.45833333333333E-01,-9.87413194444444E-02, 1-1.43312053915895E-01,-3.17227202678414E-01,-9.42429147957120E-01, 2-3.51120304082635E+00,-1.57272636203680E+01,-8.22814390971859E+01, 3-4.92355370523671E+02,-3.31621856854797E+03/ DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), 1 C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), 2 C(19), C(20), C(21), C(22), C(23), C(24)/ 3 -2.08333333333333E-01, 1.25000000000000E-01, 4 3.34201388888889E-01, -4.01041666666667E-01, 5 7.03125000000000E-02, -1.02581259645062E+00, 6 1.84646267361111E+00, -8.91210937500000E-01, 7 7.32421875000000E-02, 4.66958442342625E+00, 8 -1.12070026162230E+01, 8.78912353515625E+00, 9 -2.36408691406250E+00, 1.12152099609375E-01, A -2.82120725582002E+01, 8.46362176746007E+01, B -9.18182415432400E+01, 4.25349987453885E+01, C -7.36879435947963E+00, 2.27108001708984E-01, D 2.12570130039217E+02, -7.65252468141182E+02, E 1.05999045252800E+03, -6.99579627376133E+02/ DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), 1 C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), 2 C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ 3 2.18190511744212E+02, -2.64914304869516E+01, 4 5.72501420974731E-01, -1.91945766231841E+03, 5 8.06172218173731E+03, -1.35865500064341E+04, 6 1.16553933368645E+04, -5.30564697861340E+03, 7 1.20090291321635E+03, -1.08090919788395E+02, 8 1.72772750258446E+00, 2.02042913309661E+04, 9 -9.69805983886375E+04, 1.92547001232532E+05, A -2.03400177280416E+05, 1.22200464983017E+05, B -4.11926549688976E+04, 7.10951430248936E+03, C -4.93915304773088E+02, 6.07404200127348E+00, D -2.42919187900551E+05, 1.31176361466298E+06, E -2.99801591853811E+06, 3.76327129765640E+06/ DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), 1 C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), 2 C(65)/ 3 -2.81356322658653E+06, 1.26836527332162E+06, 4 -3.31645172484564E+05, 4.52187689813627E+04, 5 -2.49983048181121E+03, 2.43805296995561E+01, 6 3.28446985307204E+06, -1.97068191184322E+07, 7 5.09526024926646E+07, -7.41051482115327E+07, 8 6.63445122747290E+07, -3.75671766607634E+07, 9 1.32887671664218E+07, -2.78561812808645E+06, A 3.08186404612662E+05, -1.38860897537170E+04, B 1.10017140269247E+02/ DATA ALFA1(1,1), ALFA1(2,1), ALFA1(3,1), ALFA1(4,1), ALFA1(5,1), 1 ALFA1(6,1), ALFA1(7,1), ALFA1(8,1), ALFA1(9,1), ALFA1(10,1), 2 ALFA1(11,1),ALFA1(12,1),ALFA1(13,1),ALFA1(14,1),ALFA1(15,1), 3 ALFA1(16,1),ALFA1(17,1),ALFA1(18,1),ALFA1(19,1),ALFA1(20,1), 4 ALFA1(21,1),ALFA1(22,1),ALFA1(23,1),ALFA1(24,1),ALFA1(25,1), 5 ALFA1(26,1) /-4.44444444444444E-03,-9.22077922077922E-04, 6-8.84892884892885E-05, 1.65927687832450E-04, 2.46691372741793E-04, 7 2.65995589346255E-04, 2.61824297061501E-04, 2.48730437344656E-04, 8 2.32721040083232E-04, 2.16362485712365E-04, 2.00738858762752E-04, 9 1.86267636637545E-04, 1.73060775917876E-04, 1.61091705929016E-04, 1 1.50274774160908E-04, 1.40503497391270E-04, 1.31668816545923E-04, 2 1.23667445598253E-04, 1.16405271474738E-04, 1.09798298372713E-04, 3 1.03772410422993E-04, 9.82626078369363E-05, 9.32120517249503E-05, 4 8.85710852478712E-05, 8.42963105715700E-05, 8.03497548407791E-05/ DATA ALFA1(1,2), ALFA1(2,2), ALFA1(3,2), ALFA1(4,2), ALFA1(5,2), 1 ALFA1(6,2), ALFA1(7,2), ALFA1(8,2), ALFA1(9,2), ALFA1(10,2), 2 ALFA1(11,2),ALFA1(12,2),ALFA1(13,2),ALFA1(14,2),ALFA1(15,2), 3 ALFA1(16,2),ALFA1(17,2),ALFA1(18,2),ALFA1(19,2),ALFA1(20,2), 4 ALFA1(21,2),ALFA1(22,2),ALFA1(23,2),ALFA1(24,2),ALFA1(25,2), 5 ALFA1(26,2) / 6.93735541354589E-04, 2.32241745182922E-04, 6-1.41986273556691E-05,-1.16444931672049E-04,-1.50803558053049E-04, 7-1.55121924918096E-04,-1.46809756646466E-04,-1.33815503867491E-04, 8-1.19744975684254E-04,-1.06184319207974E-04,-9.37699549891194E-05, 9-8.26923045588193E-05,-7.29374348155221E-05,-6.44042357721016E-05, 1-5.69611566009369E-05,-5.04731044303562E-05,-4.48134868008883E-05, 2-3.98688727717599E-05,-3.55400532972042E-05,-3.17414256609022E-05, 3-2.83996793904175E-05,-2.54522720634871E-05,-2.28459297164725E-05, 4-2.05352753106481E-05,-1.84816217627666E-05,-1.66519330021394E-05/ DATA ALFA2(1,1), ALFA2(2,1), ALFA2(3,1), ALFA2(4,1), ALFA2(5,1), 1 ALFA2(6,1), ALFA2(7,1), ALFA2(8,1), ALFA2(9,1), ALFA2(10,1), 2 ALFA2(11,1),ALFA2(12,1),ALFA2(13,1),ALFA2(14,1),ALFA2(15,1), 3 ALFA2(16,1),ALFA2(17,1),ALFA2(18,1),ALFA2(19,1),ALFA2(20,1), 4 ALFA2(21,1),ALFA2(22,1),ALFA2(23,1),ALFA2(24,1),ALFA2(25,1), 5 ALFA2(26,1) /-3.54211971457744E-04,-1.56161263945159E-04, 6 3.04465503594936E-05, 1.30198655773243E-04, 1.67471106699712E-04, 7 1.70222587683593E-04, 1.56501427608595E-04, 1.36339170977445E-04, 8 1.14886692029825E-04, 9.45869093034688E-05, 7.64498419250898E-05, 9 6.07570334965197E-05, 4.74394299290509E-05, 3.62757512005344E-05, 1 2.69939714979225E-05, 1.93210938247939E-05, 1.30056674793963E-05, 2 7.82620866744497E-06, 3.59257485819352E-06, 1.44040049814252E-07, 3-2.65396769697939E-06,-4.91346867098486E-06,-6.72739296091248E-06, 4-8.17269379678658E-06,-9.31304715093561E-06,-1.02011418798016E-05/ DATA ALFA2(1,2), ALFA2(2,2), ALFA2(3,2), ALFA2(4,2), ALFA2(5,2), 1 ALFA2(6,2), ALFA2(7,2), ALFA2(8,2), ALFA2(9,2), ALFA2(10,2), 2 ALFA2(11,2),ALFA2(12,2),ALFA2(13,2),ALFA2(14,2),ALFA2(15,2), 3 ALFA2(16,2),ALFA2(17,2),ALFA2(18,2),ALFA2(19,2),ALFA2(20,2), 4 ALFA2(21,2),ALFA2(22,2),ALFA2(23,2),ALFA2(24,2),ALFA2(25,2), 5 ALFA2(26,2) / 3.78194199201773E-04, 2.02471952761816E-04, 6-6.37938506318862E-05,-2.38598230603006E-04,-3.10916256027362E-04, 7-3.13680115247576E-04,-2.78950273791323E-04,-2.28564082619141E-04, 8-1.75245280340847E-04,-1.25544063060690E-04,-8.22982872820208E-05, 9-4.62860730588116E-05,-1.72334302366962E-05, 5.60690482304602E-06, 1 2.31395443148287E-05, 3.62642745856794E-05, 4.58006124490189E-05, 2 5.24595294959114E-05, 5.68396208545815E-05, 5.94349820393104E-05, 3 6.06478527578422E-05, 6.08023907788436E-05, 6.01577894539460E-05, 4 5.89199657344698E-05, 5.72515823777593E-05, 5.52804375585853E-05/ DATA BETA1(1,1), BETA1(2,1), BETA1(3,1), BETA1(4,1), BETA1(5,1), 1 BETA1(6,1), BETA1(7,1), BETA1(8,1), BETA1(9,1), BETA1(10,1), 2 BETA1(11,1),BETA1(12,1),BETA1(13,1),BETA1(14,1),BETA1(15,1), 3 BETA1(16,1),BETA1(17,1),BETA1(18,1),BETA1(19,1),BETA1(20,1), 4 BETA1(21,1),BETA1(22,1),BETA1(23,1),BETA1(24,1),BETA1(25,1), 5 BETA1(26,1) / 1.79988721413553E-02, 5.59964911064388E-03, 6 2.88501402231133E-03, 1.80096606761054E-03, 1.24753110589199E-03, 7 9.22878876572938E-04, 7.14430421727287E-04, 5.71787281789705E-04, 8 4.69431007606482E-04, 3.93232835462917E-04, 3.34818889318298E-04, 9 2.88952148495752E-04, 2.52211615549573E-04, 2.22280580798883E-04, 1 1.97541838033063E-04, 1.76836855019718E-04, 1.59316899661821E-04, 2 1.44347930197334E-04, 1.31448068119965E-04, 1.20245444949303E-04, 3 1.10449144504599E-04, 1.01828770740567E-04, 9.41998224204238E-05, 4 8.74130545753834E-05, 8.13466262162801E-05, 7.59002269646219E-05/ DATA BETA1(1,2), BETA1(2,2), BETA1(3,2), BETA1(4,2), BETA1(5,2), 1 BETA1(6,2), BETA1(7,2), BETA1(8,2), BETA1(9,2), BETA1(10,2), 2 BETA1(11,2),BETA1(12,2),BETA1(13,2),BETA1(14,2),BETA1(15,2), 3 BETA1(16,2),BETA1(17,2),BETA1(18,2),BETA1(19,2),BETA1(20,2), 4 BETA1(21,2),BETA1(22,2),BETA1(23,2),BETA1(24,2),BETA1(25,2), 5 BETA1(26,2) /-1.49282953213429E-03,-8.78204709546389E-04, 6-5.02916549572035E-04,-2.94822138512746E-04,-1.75463996970783E-04, 7-1.04008550460816E-04,-5.96141953046458E-05,-3.12038929076098E-05, 8-1.26089735980230E-05,-2.42892608575730E-07, 8.05996165414274E-06, 9 1.36507009262147E-05, 1.73964125472926E-05, 1.98672978842134E-05, 1 2.14463263790823E-05, 2.23954659232457E-05, 2.28967783814713E-05, 2 2.30785389811178E-05, 2.30321976080909E-05, 2.28236073720349E-05, 3 2.25005881105292E-05, 2.20981015361991E-05, 2.16418427448104E-05, 4 2.11507649256221E-05, 2.06388749782171E-05, 2.01165241997082E-05/ DATA BETA2(1,1), BETA2(2,1), BETA2(3,1), BETA2(4,1), BETA2(5,1), 1 BETA2(6,1), BETA2(7,1), BETA2(8,1), BETA2(9,1), BETA2(10,1), 2 BETA2(11,1),BETA2(12,1),BETA2(13,1),BETA2(14,1),BETA2(15,1), 3 BETA2(16,1),BETA2(17,1),BETA2(18,1),BETA2(19,1),BETA2(20,1), 4 BETA2(21,1),BETA2(22,1),BETA2(23,1),BETA2(24,1),BETA2(25,1), 5 BETA2(26,1) / 5.52213076721293E-04, 4.47932581552385E-04, 6 2.79520653992021E-04, 1.52468156198447E-04, 6.93271105657044E-05, 7 1.76258683069991E-05,-1.35744996343269E-05,-3.17972413350427E-05, 8-4.18861861696693E-05,-4.69004889379141E-05,-4.87665447413787E-05, 9-4.87010031186735E-05,-4.74755620890087E-05,-4.55813058138628E-05, 1-4.33309644511266E-05,-4.09230193157750E-05,-3.84822638603221E-05, 2-3.60857167535411E-05,-3.37793306123367E-05,-3.15888560772110E-05, 3-2.95269561750807E-05,-2.75978914828336E-05,-2.58006174666884E-05, 4-2.41308356761280E-05,-2.25823509518346E-05,-2.11479656768913E-05/ DATA BETA2(1,2), BETA2(2,2), BETA2(3,2), BETA2(4,2), BETA2(5,2), 1 BETA2(6,2), BETA2(7,2), BETA2(8,2), BETA2(9,2), BETA2(10,2), 2 BETA2(11,2),BETA2(12,2),BETA2(13,2),BETA2(14,2),BETA2(15,2), 3 BETA2(16,2),BETA2(17,2),BETA2(18,2),BETA2(19,2),BETA2(20,2), 4 BETA2(21,2),BETA2(22,2),BETA2(23,2),BETA2(24,2),BETA2(25,2), 5 BETA2(26,2) /-4.74617796559960E-04,-4.77864567147321E-04, 6-3.20390228067038E-04,-1.61105016119962E-04,-4.25778101285435E-05, 7 3.44571294294968E-05, 7.97092684075675E-05, 1.03138236708272E-04, 8 1.12466775262204E-04, 1.13103642108481E-04, 1.08651634848774E-04, 9 1.01437951597662E-04, 9.29298396593364E-05, 8.40293133016090E-05, 1 7.52727991349134E-05, 6.69632521975731E-05, 5.92564547323195E-05, 2 5.22169308826976E-05, 4.58539485165361E-05, 4.01445513891487E-05, 3 3.50481730031328E-05, 3.05157995034347E-05, 2.64956119950516E-05, 4 2.29363633690998E-05, 1.97893056664022E-05, 1.70091984636413E-05/ DATA BETA3(1,1), BETA3(2,1), BETA3(3,1), BETA3(4,1), BETA3(5,1), 1 BETA3(6,1), BETA3(7,1), BETA3(8,1), BETA3(9,1), BETA3(10,1), 2 BETA3(11,1),BETA3(12,1),BETA3(13,1),BETA3(14,1),BETA3(15,1), 3 BETA3(16,1),BETA3(17,1),BETA3(18,1),BETA3(19,1),BETA3(20,1), 4 BETA3(21,1),BETA3(22,1),BETA3(23,1),BETA3(24,1),BETA3(25,1), 5 BETA3(26,1) / 7.36465810572578E-04, 8.72790805146194E-04, 6 6.22614862573135E-04, 2.85998154194304E-04, 3.84737672879366E-06, 7-1.87906003636972E-04,-2.97603646594555E-04,-3.45998126832656E-04, 8-3.53382470916038E-04,-3.35715635775049E-04,-3.04321124789040E-04, 9-2.66722723047613E-04,-2.27654214122820E-04,-1.89922611854562E-04, 1-1.55058918599094E-04,-1.23778240761874E-04,-9.62926147717644E-05, 2-7.25178327714425E-05,-5.22070028895634E-05,-3.50347750511901E-05, 3-2.06489761035552E-05,-8.70106096849767E-06, 1.13698686675100E-06, 4 9.16426474122779E-06, 1.56477785428873E-05, 2.08223629482467E-05/ DATA GAMA(1), GAMA(2), GAMA(3), GAMA(4), GAMA(5), 1 GAMA(6), GAMA(7), GAMA(8), GAMA(9), GAMA(10), 2 GAMA(11), GAMA(12), GAMA(13), GAMA(14), GAMA(15), 3 GAMA(16), GAMA(17), GAMA(18), GAMA(19), GAMA(20), 4 GAMA(21), GAMA(22), GAMA(23), GAMA(24), GAMA(25), 5 GAMA(26) / 6.29960524947437E-01, 2.51984209978975E-01, 6 1.54790300415656E-01, 1.10713062416159E-01, 8.57309395527395E-02, 7 6.97161316958684E-02, 5.86085671893714E-02, 5.04698873536311E-02, 8 4.42600580689155E-02, 3.93720661543510E-02, 3.54283195924455E-02, 9 3.21818857502098E-02, 2.94646240791158E-02, 2.71581677112934E-02, 1 2.51768272973862E-02, 2.34570755306079E-02, 2.19508390134907E-02, 2 2.06210828235646E-02, 1.94388240897881E-02, 1.83810633800683E-02, 3 1.74293213231963E-02, 1.65685837786612E-02, 1.57865285987918E-02, 4 1.50729501494096E-02, 1.44193250839955E-02, 1.38184805735342E-02/ C ------------------------------------------------------------------ FN = FNU IFLW = 0 DO 170 JN=1,IN XX = X/FN WK(1) = 1.0E0 - XX*XX ABW2 = ABS(WK(1)) WK(2) = SQRT(ABW2) WK(7) = FN**CON2 IF (ABW2.GT.0.27750E0) GO TO 80 C C ASYMPTOTIC EXPANSION C CASES NEAR X=FN, ABS(1.-(X/FN)**2).LE.0.2775 C COEFFICIENTS OF ASYMPTOTIC EXPANSION BY SERIES C C ZETA AND TRUNCATION FOR A(ZETA) AND B(ZETA) SERIES C C KMAX IS TRUNCATION INDEX FOR A(ZETA) AND B(ZETA) SERIES=MAX(2,SA) C SA = 0.0E0 IF (ABW2.EQ.0.0E0) GO TO 10 SA = TOLS/ALOG(ABW2) 10 SB = SA DO 20 I=1,5 AKM = AMAX1(SA,2.0E0) KMAX(I) = INT(AKM) SA = SA + SB 20 CONTINUE KB = KMAX(5) KLAST = KB - 1 SA = GAMA(KB) DO 30 K=1,KLAST KB = KB - 1 SA = SA*WK(1) + GAMA(KB) 30 CONTINUE Z = WK(1)*SA AZ = ABS(Z) RTZ = SQRT(AZ) WK(3) = CON1*AZ*RTZ WK(4) = WK(3)*FN WK(5) = RTZ*WK(7) WK(6) = -WK(5)*WK(5) IF(Z.LE.0.0E0) GO TO 35 IF(WK(4).GT.ELIM) GO TO 75 WK(6) = -WK(6) 35 CONTINUE PHI = SQRT(SQRT(SA+SA+SA+SA)) C C B(ZETA) FOR S=0 C KB = KMAX(5) KLAST = KB - 1 SB = BETA(KB,1) DO 40 K=1,KLAST KB = KB - 1 SB = SB*WK(1) + BETA(KB,1) 40 CONTINUE KSP1 = 1 FN2 = FN*FN RFN2 = 1.0E0/FN2 RDEN = 1.0E0 ASUM = 1.0E0 RELB = TOL*ABS(SB) BSUM = SB DO 60 KS=1,4 KSP1 = KSP1 + 1 RDEN = RDEN*RFN2 C C A(ZETA) AND B(ZETA) FOR S=1,2,3,4 C KSTEMP = 5 - KS KB = KMAX(KSTEMP) KLAST = KB - 1 SA = ALFA(KB,KS) SB = BETA(KB,KSP1) DO 50 K=1,KLAST KB = KB - 1 SA = SA*WK(1) + ALFA(KB,KS) SB = SB*WK(1) + BETA(KB,KSP1) 50 CONTINUE TA = SA*RDEN TB = SB*RDEN ASUM = ASUM + TA BSUM = BSUM + TB IF (ABS(TA).LE.TOL .AND. ABS(TB).LE.RELB) GO TO 70 60 CONTINUE 70 CONTINUE BSUM = BSUM/(FN*WK(7)) GO TO 160 C 75 CONTINUE IFLW = 1 RETURN C 80 CONTINUE UPOL(1) = 1.0E0 TAU = 1.0E0/WK(2) T2 = 1.0E0/WK(1) IF (WK(1).GE.0.0E0) GO TO 90 C C CASES FOR (X/FN).GT.SQRT(1.2775) C WK(3) = ABS(WK(2)-ATAN(WK(2))) WK(4) = WK(3)*FN RCZ = -CON1/WK(4) Z32 = 1.5E0*WK(3) RTZ = Z32**CON2 WK(5) = RTZ*WK(7) WK(6) = -WK(5)*WK(5) GO TO 100 90 CONTINUE C C CASES FOR (X/FN).LT.SQRT(0.7225) C WK(3) = ABS(ALOG((1.0E0+WK(2))/XX)-WK(2)) WK(4) = WK(3)*FN RCZ = CON1/WK(4) IF(WK(4).GT.ELIM) GO TO 75 Z32 = 1.5E0*WK(3) RTZ = Z32**CON2 WK(7) = FN**CON2 WK(5) = RTZ*WK(7) WK(6) = WK(5)*WK(5) 100 CONTINUE PHI = SQRT((RTZ+RTZ)*TAU) TB = 1.0E0 ASUM = 1.0E0 TFN = TAU/FN UPOL(2) = (C(1)*T2+C(2))*TFN CRZ32 = CON548*RCZ BSUM = UPOL(2) + CRZ32 RELB = TOL*ABS(BSUM) AP = TFN KS = 0 KP1 = 2 RZDEN = RCZ L = 2 DO 140 LR=2,8,2 C C COMPUTE TWO U POLYNOMIALS FOR NEXT A(ZETA) AND B(ZETA) C LRP1 = LR + 1 DO 120 K=LR,LRP1 KS = KS + 1 KP1 = KP1 + 1 L = L + 1 S1 = C(L) DO 110 J=2,KP1 L = L + 1 S1 = S1*T2 + C(L) 110 CONTINUE AP = AP*TFN UPOL(KP1) = AP*S1 CR(KS) = BR(KS)*RZDEN RZDEN = RZDEN*RCZ DR(KS) = AR(KS)*RZDEN 120 CONTINUE SUMA = UPOL(LRP1) SUMB = UPOL(LR+2) + UPOL(LRP1)*CRZ32 JU = LRP1 DO 130 JR=1,LR JU = JU - 1 SUMA = SUMA + CR(JR)*UPOL(JU) SUMB = SUMB + DR(JR)*UPOL(JU) 130 CONTINUE TB = -TB IF (WK(1).GT.0.0E0) TB = ABS(TB) ASUM = ASUM + SUMA*TB BSUM = BSUM + SUMB*TB IF (ABS(SUMA).LE.TOL .AND. ABS(SUMB).LE.RELB) GO TO 150 140 CONTINUE 150 TB = WK(5) IF (WK(1).GT.0.0E0) TB = -TB BSUM = BSUM/TB C 160 CONTINUE CALL FUNJY(WK(6), WK(5), WK(4), FI, DFI) Y(JN) = FLGJY*PHI*(FI*ASUM+DFI*BSUM)/WK(7) FN = FN - FLGJY 170 CONTINUE RETURN END SUBROUTINE JAIRY(X,RX,C,AI,DAI) C C JAIRY COMPUTES THE AIRY FUNCTION AI(X) C AND ITS DERIVATIVE DAI(X) FOR JBESS C C INPUT C C X - ARGUMENT, COMPUTED BY JBESS, X UNRESTRICTED C RX - RX=SQRT(ABS(X)), COMPUTED BY JBESS C C - C=2.*(ABS(X)**1.5)/3., COMPUTED BY JBESS C C OUTPUT C C AI - VALUE OF FUNCTION AI(X) C DAI - VALUE OF THE DERIVATIVE DAI(X) C C WRITTEN BY C C D. E. AMOS C S. L. DANIEL C M. K. WESTON C DIMENSION AK1(14),AK2(23),AK3(14) DIMENSION AJP(19),AJN(19),A(15),B(15) DIMENSION DAK1(14),DAK2(24),DAK3(14) DIMENSION DAJP(19),DAJN(19),DA(15),DB(15) C DATA N1,N2,N3,N4/14,23,19,15/ DATA M1,M2,M3,M4/12,21,17,13/ DATA FPI12,CON1,CON2,CON3,CON4,CON5/ 1 1.30899693899575E+00, 6.66666666666667E-01, 5.03154716196777E+00, 2 3.80004589867293E-01, 8.33333333333333E-01, 8.66025403784439E-01/ C DATA AK1(1) / 2.20423090987793E-01/, 1 AK1(2) /-1.25290242787700E-01/, AK1(3) / 1.03881163359194E-02/, 2 AK1(4) / 8.22844152006343E-04/, AK1(5) /-2.34614345891226E-04/, 3 AK1(6) / 1.63824280172116E-05/, AK1(7) / 3.06902589573189E-07/, 4 AK1(8) /-1.29621999359332E-07/, AK1(9) / 8.22908158823668E-09/, 5 AK1(10)/ 1.53963968623298E-11/, AK1(11)/-3.39165465615682E-11/, 6 AK1(12)/ 2.03253257423626E-12/, AK1(13)/-1.10679546097884E-14/, 7 AK1(14)/-5.16169497785080E-15/ C DATA AK2(1) / 2.74366150869598E-01/, 1 AK2(2) / 5.39790969736903E-03/, AK2(3) /-1.57339220621190E-03/, 2 AK2(4) / 4.27427528248750E-04/, AK2(5) /-1.12124917399925E-04/, 3 AK2(6) / 2.88763171318904E-05/, AK2(7) /-7.36804225370554E-06/, 4 AK2(8) / 1.87290209741024E-06/, AK2(9) /-4.75892793962291E-07/, 5 AK2(10)/ 1.21130416955909E-07/, AK2(11)/-3.09245374270614E-08/, 6 AK2(12)/ 7.92454705282654E-09/, AK2(13)/-2.03902447167914E-09/, 7 AK2(14)/ 5.26863056595742E-10/, AK2(15)/-1.36704767639569E-10/, 8 AK2(16)/ 3.56141039013708E-11/, AK2(17)/-9.31388296548430E-12/, 9 AK2(18)/ 2.44464450473635E-12/, AK2(19)/-6.43840261990955E-13/, 1 AK2(20)/ 1.70106030559349E-13/, AK2(21)/-4.50760104503281E-14/, 2 AK2(22)/ 1.19774799164811E-14/, AK2(23)/-3.19077040865066E-15/ C DATA AK3(1) / 2.80271447340791E-01/, 1 AK3(2) /-1.78127042844379E-03/, AK3(3) / 4.03422579628999E-05/, 2 AK3(4) /-1.63249965269003E-06/, AK3(5) / 9.21181482476768E-08/, 3 AK3(6) /-6.52294330229155E-09/, AK3(7) / 5.47138404576546E-10/, 4 AK3(8) /-5.24408251800260E-11/, AK3(9) / 5.60477904117209E-12/, 5 AK3(10)/-6.56375244639313E-13/, AK3(11)/ 8.31285761966247E-14/, 6 AK3(12)/-1.12705134691063E-14/, AK3(13)/ 1.62267976598129E-15/, 7 AK3(14)/-2.46480324312426E-16/ C DATA AJP(1) / 7.78952966437581E-02/, 1 AJP(2) /-1.84356363456801E-01/, AJP(3) / 3.01412605216174E-02/, 2 AJP(4) / 3.05342724277608E-02/, AJP(5) /-4.95424702513079E-03/, 3 AJP(6) /-1.72749552563952E-03/, AJP(7) / 2.43137637839190E-04/, 4 AJP(8) / 5.04564777517082E-05/, AJP(9) /-6.16316582695208E-06/, 5 AJP(10)/-9.03986745510768E-07/, AJP(11)/ 9.70243778355884E-08/, 6 AJP(12)/ 1.09639453305205E-08/, AJP(13)/-1.04716330588766E-09/, 7 AJP(14)/-9.60359441344646E-11/, AJP(15)/ 8.25358789454134E-12/, 8 AJP(16)/ 6.36123439018768E-13/, AJP(17)/-4.96629614116015E-14/, 9 AJP(18)/-3.29810288929615E-15/, AJP(19)/ 2.35798252031104E-16/ C DATA AJN(1) / 3.80497887617242E-02/, 1 AJN(2) /-2.45319541845546E-01/, AJN(3) / 1.65820623702696E-01/, 2 AJN(4) / 7.49330045818789E-02/, AJN(5) /-2.63476288106641E-02/, 3 AJN(6) /-5.92535597304981E-03/, AJN(7) / 1.44744409589804E-03/, 4 AJN(8) / 2.18311831322215E-04/, AJN(9) /-4.10662077680304E-05/, 5 AJN(10)/-4.66874994171766E-06/, AJN(11)/ 7.15218807277160E-07/, 6 AJN(12)/ 6.52964770854633E-08/, AJN(13)/-8.44284027565946E-09/, 7 AJN(14)/-6.44186158976978E-10/, AJN(15)/ 7.20802286505285E-11/, 8 AJN(16)/ 4.72465431717846E-12/, AJN(17)/-4.66022632547045E-13/, 9 AJN(18)/-2.67762710389189E-14/, AJN(19)/ 2.36161316570019E-15/ C DATA A(1) / 4.90275424742791E-01/, A(2) / 1.57647277946204E-03/, 1 A(3) /-9.66195963140306E-05/, A(4) / 1.35916080268815E-07/, 2 A(5) / 2.98157342654859E-07/, A(6) /-1.86824767559979E-08/, 3 A(7) /-1.03685737667141E-09/, A(8) / 3.28660818434328E-10/, 4 A(9) /-2.57091410632780E-11/, A(10)/-2.32357655300677E-12/, 5 A(11)/ 9.57523279048255E-13/, A(12)/-1.20340828049719E-13/, 6 A(13)/-2.90907716770715E-15/, A(14)/ 4.55656454580149E-15/, 7 A(15)/-9.99003874810259E-16/ C DATA B(1) / 2.78593552803079E-01/, B(2) /-3.52915691882584E-03/, 1 B(3) /-2.31149677384994E-05/, B(4) / 4.71317842263560E-06/, 2 B(5) /-1.12415907931333E-07/, B(6) /-2.00100301184339E-08/, 3 B(7) / 2.60948075302193E-09/, B(8) /-3.55098136101216E-11/, 4 B(9) /-3.50849978423875E-11/, B(10)/ 5.83007187954202E-12/, 5 B(11)/-2.04644828753326E-13/, B(12)/-1.10529179476742E-13/, 6 B(13)/ 2.87724778038775E-14/, B(14)/-2.88205111009939E-15/, 7 B(15)/-3.32656311696166E-16/ C DATA N1D,N2D,N3D,N4D/14,24,19,15/ DATA M1D,M2D,M3D,M4D/12,22,17,13/ C DATA DAK1(1) / 2.04567842307887E-01/, 1 DAK1(2) /-6.61322739905664E-02/, DAK1(3) /-8.49845800989287E-03/, 2 DAK1(4) / 3.12183491556289E-03/, DAK1(5) /-2.70016489829432E-04/, 3 DAK1(6) /-6.35636298679387E-06/, DAK1(7) / 3.02397712409509E-06/, 4 DAK1(8) /-2.18311195330088E-07/, DAK1(9) /-5.36194289332826E-10/, 5 DAK1(10)/ 1.13098035622310E-09/, DAK1(11)/-7.43023834629073E-11/, 6 DAK1(12)/ 4.28804170826891E-13/, DAK1(13)/ 2.23810925754539E-13/, 7 DAK1(14)/-1.39140135641182E-14/ C DATA DAK2(1) / 2.93332343883230E-01/, 1 DAK2(2) /-8.06196784743112E-03/, DAK2(3) / 2.42540172333140E-03/, 2 DAK2(4) /-6.82297548850235E-04/, DAK2(5) / 1.85786427751181E-04/, 3 DAK2(6) /-4.97457447684059E-05/, DAK2(7) / 1.32090681239497E-05/, 4 DAK2(8) /-3.49528240444943E-06/, DAK2(9) / 9.24362451078835E-07/, 5 DAK2(10)/-2.44732671521867E-07/, DAK2(11)/ 6.49307837648910E-08/, 6 DAK2(12)/-1.72717621501538E-08/, DAK2(13)/ 4.60725763604656E-09/, 7 DAK2(14)/-1.23249055291550E-09/, DAK2(15)/ 3.30620409488102E-10/, 8 DAK2(16)/-8.89252099772401E-11/, DAK2(17)/ 2.39773319878298E-11/, 9 DAK2(18)/-6.48013921153450E-12/, DAK2(19)/ 1.75510132023731E-12/, 1 DAK2(20)/-4.76303829833637E-13/, DAK2(21)/ 1.29498241100810E-13/, 2 DAK2(22)/-3.52679622210430E-14/, DAK2(23)/ 9.62005151585923E-15/, 3 DAK2(24)/-2.62786914342292E-15/ C DATA DAK3(1) / 2.84675828811349E-01/, 1 DAK3(2) / 2.53073072619080E-03/, DAK3(3) /-4.83481130337976E-05/, 2 DAK3(4) / 1.84907283946343E-06/, DAK3(5) /-1.01418491178576E-07/, 3 DAK3(6) / 7.05925634457153E-09/, DAK3(7) /-5.85325291400382E-10/, 4 DAK3(8) / 5.56357688831339E-11/, DAK3(9) /-5.90889094779500E-12/, 5 DAK3(10)/ 6.88574353784436E-13/, DAK3(11)/-8.68588256452194E-14/, 6 DAK3(12)/ 1.17374762617213E-14/, DAK3(13)/-1.68523146510923E-15/, 7 DAK3(14)/ 2.55374773097056E-16/ C DATA DAJP(1) / 6.53219131311457E-02/, 1 DAJP(2) /-1.20262933688823E-01/, DAJP(3) / 9.78010236263823E-03/, 2 DAJP(4) / 1.67948429230505E-02/, DAJP(5) /-1.97146140182132E-03/, 3 DAJP(6) /-8.45560295098867E-04/, DAJP(7) / 9.42889620701976E-05/, 4 DAJP(8) / 2.25827860945475E-05/, DAJP(9) /-2.29067870915987E-06/, 5 DAJP(10)/-3.76343991136919E-07/, DAJP(11)/ 3.45663933559565E-08/, 6 DAJP(12)/ 4.29611332003007E-09/, DAJP(13)/-3.58673691214989E-10/, 7 DAJP(14)/-3.57245881361895E-11/, DAJP(15)/ 2.72696091066336E-12/, 8 DAJP(16)/ 2.26120653095771E-13/, DAJP(17)/-1.58763205238303E-14/, 9 DAJP(18)/-1.12604374485125E-15/, DAJP(19)/ 7.31327529515367E-17/ C DATA DAJN(1) / 1.08594539632967E-02/, 1 DAJN(2) / 8.53313194857091E-02/, DAJN(3) /-3.15277068113058E-01/, 2 DAJN(4) /-8.78420725294257E-02/, DAJN(5) / 5.53251906976048E-02/, 3 DAJN(6) / 9.41674060503241E-03/, DAJN(7) /-3.32187026018996E-03/, 4 DAJN(8) /-4.11157343156826E-04/, DAJN(9) / 1.01297326891346E-04/, 5 DAJN(10)/ 9.87633682208396E-06/, DAJN(11)/-1.87312969812393E-06/, 6 DAJN(12)/-1.50798500131468E-07/, DAJN(13)/ 2.32687669525394E-08/, 7 DAJN(14)/ 1.59599917419225E-09/, DAJN(15)/-2.07665922668385E-10/, 8 DAJN(16)/-1.24103350500302E-11/, DAJN(17)/ 1.39631765331043E-12/, 9 DAJN(18)/ 7.39400971155740E-14/, DAJN(19)/-7.32887475627500E-15/ C DATA DA(1) / 4.91627321104601E-01/, DA(2) / 3.11164930427489E-03/, 1 DA(3) / 8.23140762854081E-05/, DA(4) /-4.61769776172142E-06/, 2 DA(5) /-6.13158880534626E-08/, DA(6) / 2.87295804656520E-08/, 3 DA(7) /-1.81959715372117E-09/, DA(8) /-1.44752826642035E-10/, 4 DA(9) / 4.53724043420422E-11/, DA(10)/-3.99655065847223E-12/, 5 DA(11)/-3.24089119830323E-13/, DA(12)/ 1.62098952568741E-13/, 6 DA(13)/-2.40765247974057E-14/, DA(14)/ 1.69384811284491E-16/, 7 DA(15)/ 8.17900786477396E-16/ C DATA DB(1) /-2.77571356944231E-01/, DB(2) / 4.44212833419920E-03/, 1 DB(3) /-8.42328522190089E-05/, DB(4) /-2.58040318418710E-06/, 2 DB(5) / 3.42389720217621E-07/, DB(6) /-6.24286894709776E-09/, 3 DB(7) /-2.36377836844577E-09/, DB(8) / 3.16991042656673E-10/, 4 DB(9) /-4.40995691658191E-12/, DB(10)/-5.18674221093575E-12/, 5 DB(11)/ 9.64874015137022E-13/, DB(12)/-4.90190576608710E-14/, 6 DB(13)/-1.77253430678112E-14/, DB(14)/ 5.55950610442662E-15/, 7 DB(15)/-7.11793337579530E-16/ C ------------------- IF(X.LT.0.) GO TO 300 IF(C.GT.5.) GO TO 200 IF(X.GT.1.2) GO TO 150 T=(X+X-1.2)*CON4 TT = T + T J=N1 F1=AK1(J) F2=0. DO 105 I=1,M1 J=J-1 TEMP1=F1 F1=TT*F1-F2+AK1(J) F2=TEMP1 105 CONTINUE AI=T*F1-F2+AK1(1) C J=N1D F1=DAK1(J) F2=0. DO 106 I=1,M1D J=J-1 TEMP1=F1 F1=TT*F1-F2+DAK1(J) F2=TEMP1 106 CONTINUE DAI=-(T*F1-F2+DAK1(1)) RETURN C 150 CONTINUE T=(X+X-CON2)*CON3 TT = T + T J=N2 F1=AK2(J) F2=0. DO 155 I=1,M2 J=J-1 TEMP1=F1 F1=TT*F1-F2+AK2(J) F2=TEMP1 155 CONTINUE RTRX=SQRT(RX) EC=EXP(-C) AI=EC*(T*F1-F2+AK2(1))/RTRX J=N2D F1=DAK2(J) F2=0. DO 156 I=1,M2D J=J-1 TEMP1=F1 F1=TT*F1-F2+DAK2(J) F2=TEMP1 156 CONTINUE DAI=-EC*(T*F1-F2+DAK2(1))*RTRX RETURN C 200 CONTINUE T=10./C-1. TT=T+T J=N1 F1=AK3(J) F2=0. DO 205 I=1,M1 J=J-1 TEMP1=F1 F1=TT*F1-F2+AK3(J) F2=TEMP1 205 CONTINUE RTRX=SQRT(RX) EC=EXP(-C) AI=EC*(T*F1-F2+AK3(1))/RTRX J=N1D F1=DAK3(J) F2=0. DO 206 I=1,M1D J=J-1 TEMP1=F1 F1=TT*F1-F2+DAK3(J) F2=TEMP1 206 CONTINUE DAI=-RTRX*EC*(T*F1-F2+DAK3(1)) RETURN C 300 CONTINUE IF(C.GT.5.) GO TO 350 T=.4*C-1. TT=T+T J=N3 F1=AJP(J) E1=AJN(J) F2=0. E2=0. DO 305 I=1,M3 J=J-1 TEMP1=F1 TEMP2=E1 F1=TT*F1-F2+AJP(J) E1=TT*E1-E2+AJN(J) F2=TEMP1 E2=TEMP2 305 CONTINUE AI=(T*E1-E2+AJN(1))-X*(T*F1-F2+AJP(1)) J=N3D F1=DAJP(J) E1=DAJN(J) F2=0. E2=0. DO 306 I=1,M3D J=J-1 TEMP1=F1 TEMP2=E1 F1 = TT*F1-F2+DAJP(J) E1= TT*E1-E2+DAJN(J) F2=TEMP1 E2=TEMP2 306 CONTINUE DAI=X*X*(T*F1-F2+DAJP(1))+(T*E1-E2+DAJN(1)) RETURN C 350 CONTINUE T=10./C-1. TT=T+T J=N4 F1=A(J) E1=B(J) F2=0. E2=0. DO 310 I=1,M4 J=J-1 TEMP1=F1 TEMP2=E1 F1=TT*F1-F2+A(J) E1=TT*E1-E2+B(J) F2=TEMP1 E2=TEMP2 310 CONTINUE TEMP1=T*F1-F2+A(1) TEMP2=T*E1-E2+B(1) RTRX=SQRT(RX) CV=C-FPI12 CCV=COS(CV) SCV=SIN(CV) AI=(TEMP1*CCV-TEMP2*SCV)/RTRX J=N4D F1=DA(J) E1=DB(J) F2=0. E2=0. DO 311 I=1,M4D J=J-1 TEMP1=F1 TEMP2=E1 F1=TT*F1-F2+DA(J) E1=TT*E1-E2+DB(J) F2=TEMP1 E2=TEMP2 311 CONTINUE TEMP1=T*F1-F2+DA(1) TEMP2=T*E1-E2+DB(1) E1=CCV*CON5+.5*SCV E2=SCV*CON5-.5*CCV DAI=(TEMP1*E1-TEMP2*E2)*RTRX RETURN END SUBROUTINE BSSLY (A, IN, W) C ****************************************************************** C FORTRAN SUBROUTINE FOR ORDINARY BESSEL FUNCTION OF INTEGRAL ORDER C ****************************************************************** C A = ARGUMENT (COMPLEX NUMBER) C IN = ORDER (INTEGER) C W = FUNCTION OF SECOND KIND (COMPLEX NUMBER) C ------------------- COMPLEX A, W DIMENSION AZ(2) DIMENSION CD(30), CE(30) DIMENSION QZ(2), RZ(2), SZ(2), ZL(2) DIMENSION TS(2), TM(4), SM(4), SL(2), SQ(2), SR(2), AQ(2), QF(2) DATA CD(1) / 0.00000000000000E00/, CD(2) /-1.64899505142212E-2/, 1 CD(3) /-7.18621880068536E-2/, CD(4) /-1.67086878124866E-1/, 2 CD(5) /-3.02582250219469E-1/, CD(6) /-4.80613945245927E-1/, 3 CD(7) /-7.07075239357898E-1/, CD(8) /-9.92995790539516E-1/, 4 CD(9) /-1.35583925612592E00/, CD(10)/-1.82105907899132E00/, 5 CD(11)/-2.42482175310879E00/, CD(12)/-3.21956655708750E00/, 6 CD(13)/-4.28658077248384E00/, CD(14)/-5.77022816798128E00/, 7 CD(15)/-8.01371260952526E00/ DATA CD(16)/ 0.00000000000000E00/, CD(17)/-5.57742429879505E-3/, 1 CD(18)/-4.99112944172476E-2/, CD(19)/-1.37440911652397E-1/, 2 CD(20)/-2.67233784710566E-1/, CD(21)/-4.40380166808682E-1/, 3 CD(22)/-6.61813614872541E-1/, CD(23)/-9.41861077665017E-1/, 4 CD(24)/-1.29754130468326E00/, CD(25)/-1.75407696719816E00/, 5 CD(26)/-2.34755299882276E00/, CD(27)/-3.13041332689196E00/, 6 CD(28)/-4.18397120563729E00/, CD(29)/-5.65251799214994E00/, 7 CD(30)/-7.87863959810677E00/ DATA CE(1) / 0.00000000000000E00/, CE(2) /-4.80942336387447E-3/, 1 CE(3) /-1.31366200347759E-2/, CE(4) /-1.94843834008458E-2/, 2 CE(5) /-2.19948900032003E-2/, CE(6) /-2.09396625676519E-2/, 3 CE(7) /-1.74600268458650E-2/, CE(8) /-1.27937813362085E-2/, 4 CE(9) /-8.05234421796592E-3/, CE(10)/-4.15817375002760E-3/, 5 CE(11)/-1.64317738747922E-3/, CE(12)/-4.49175585314709E-4/, 6 CE(13)/-7.28594765574007E-5/, CE(14)/-5.38265230658285E-6/, 7 CE(15)/-9.93779048036289E-8/ DATA CE(16)/ 0.00000000000000E00/, CE(17)/ 7.53805779200591E-2/, 1 CE(18)/ 7.12293537403464E-2/, CE(19)/ 6.33116224228200E-2/, 2 CE(20)/ 5.28240264523301E-2/, CE(21)/ 4.13305359441492E-2/, 3 CE(22)/ 3.01350573947510E-2/, CE(23)/ 2.01043439592720E-2/, 4 CE(24)/ 1.18552223068074E-2/, CE(25)/ 5.86055510956010E-3/, 5 CE(26)/ 2.25465148267325E-3/, CE(27)/ 6.08173041536336E-4/, 6 CE(28)/ 9.84215550625747E-5/, CE(29)/ 7.32139093038089E-6/, 7 CE(30)/ 1.37279667384666E-7/ C ------------------- AZ(1)=REAL(A) AZ(2)=AIMAG(A) ZS=AZ(1)*AZ(1)+AZ(2)*AZ(2) ZL(1)=0.5*ALOG(ZS) ZL(2)=ATAN2(AZ(2),AZ(1)) AN=IABS(IN) SN=+1.0 IF(IN)002,003,003 002 IF(IN.EQ.IN/2*2)GO TO 003 SN=-1.0 003 IF(AZ(1))004,005,005 004 QZ(1)=-AZ(1) QZ(2)=-AZ(2) GO TO 006 005 QZ(1)=+AZ(1) QZ(2)=+AZ(2) 006 IF(ZS-1.0)020,020,007 007 IF(ZS-289.0)008,010,010 008 IF(-ABS(AZ(2))+0.096*AZ(1)*AZ(1))020,020,015 010 QM=SN*0.797884560802865*EXP(-0.5*ZL(1)) QF(1)=QM*COS(-0.5*ZL(2)) QF(2)=QM*SIN(-0.5*ZL(2)) IF(AN.GT.1.0)GO TO 012 PN=AN ASSIGN 011 TO LA GO TO 100 011 TS(1)=QF(1)*SM(1)-QF(2)*SM(2) TS(2)=QF(1)*SM(2)+QF(2)*SM(1) SM(1)=TS(1) SM(2)=TS(2) GO TO 029 012 PN=1.0 ASSIGN 013 TO LA GO TO 100 013 SQ(1)=-QF(1)*SM(1)+QF(2)*SM(2) SQ(2)=-QF(1)*SM(2)-QF(2)*SM(1) PN=0.0 ASSIGN 014 TO LA GO TO 100 014 SR(1)=+QF(1)*SM(1)-QF(2)*SM(2) SR(2)=+QF(1)*SM(2)+QF(2)*SM(1) GO TO 026 015 QM=SN*0.3989422804014327*EXP(-0.5*ZL(1)) QF(1)=QM*COS(-0.5*ZL(2)) QF(2)=QM*SIN(-0.5*ZL(2)) IF(AN.GT.1.0)GO TO 017 PN=AN ASSIGN 016 TO LR GO TO 112 016 TS(1)=QF(1)*SM(1)-QF(2)*SM(2) TS(2)=QF(1)*SM(2)+QF(2)*SM(1) SM(1)=TS(1) SM(2)=TS(2) GO TO 029 017 PN=1.0 ASSIGN 018 TO LR GO TO 112 018 SQ(1)=-QF(1)*SM(1)+QF(2)*SM(2) SQ(2)=-QF(1)*SM(2)-QF(2)*SM(1) PN=0.0 ASSIGN 019 TO LR GO TO 112 019 SR(1)=+QF(1)*SM(1)-QF(2)*SM(2) SR(2)=+QF(1)*SM(2)+QF(2)*SM(1) GO TO 026 020 QF(1)=SN*0.6366197723675813 QF(2)=0.0 021 IF(AN.GT.1.0)GO TO 023 PN=AN ASSIGN 022 TO LY GO TO 122 022 TS(1)=QF(1)*SM(1)-QF(2)*SM(2) TS(2)=QF(1)*SM(2)+QF(2)*SM(1) SM(1)=TS(1) SM(2)=TS(2) GO TO 029 023 PN=1.0 ASSIGN 024 TO LY GO TO 122 024 SQ(1)=-QF(1)*SM(1)+QF(2)*SM(2) SQ(2)=-QF(1)*SM(2)-QF(2)*SM(1) PN=0.0 ASSIGN 025 TO LY GO TO 122 025 SR(1)=+QF(1)*SM(1)-QF(2)*SM(2) SR(2)=+QF(1)*SM(2)+QF(2)*SM(1) 026 RZ(1)=+AZ(1)/ZS RZ(2)=-AZ(2)/ZS PN=0.0 GO TO 028 027 SQ(1)=SR(1) SQ(2)=SR(2) SR(1)=SM(1) SR(2)=SM(2) 028 SM(1)=2.0*PN*(RZ(1)*SR(1)-RZ(2)*SR(2))-SQ(1) SM(2)=2.0*PN*(RZ(1)*SR(2)+RZ(2)*SR(1))-SQ(2) PN=PN+1.0 IF(PN.LT.AN)GO TO 027 029 W=CMPLX(SM(1),SM(2)) RETURN 100 SM(1)=0.0 SM(2)=0.0 SM(3)=0.0 SM(4)=0.0 RZ(1)=+0.5*QZ(1)/ZS RZ(2)=-0.5*QZ(2)/ZS QN=PN*PN-0.25 TM(1)=1.0 TM(2)=0.0 PM=0.0 GO TO 102 101 QN=QN-2.0*PM PM=PM+1.0 TS(1)=TM(1)*RZ(1)-TM(2)*RZ(2) TS(2)=TM(1)*RZ(2)+TM(2)*RZ(1) TM(1)=-QN*TS(1)/PM TM(2)=-QN*TS(2)/PM 102 SM(1)=SM(1)+TM(1) SM(2)=SM(2)+TM(2) QN=QN-2.0*PM PM=PM+1.0 TS(1)=TM(1)*RZ(1)-TM(2)*RZ(2) TS(2)=TM(1)*RZ(2)+TM(2)*RZ(1) TM(1)=+QN*TS(1)/PM TM(2)=+QN*TS(2)/PM IF(ABS(SM(3))+ABS(TM(1)).NE.ABS(SM(3)))GO TO 103 IF(ABS(SM(4))+ABS(TM(2)).EQ.ABS(SM(4)))GO TO 104 103 SM(3)=SM(3)+TM(1) SM(4)=SM(4)+TM(2) IF(PM.LT.35.0)GO TO 101 104 AQ(1)=QZ(1)-1.57079632679490*(PN+0.5) AQ(2)=QZ(2) TS(1)=+COS(AQ(1))*0.5*(EXP(+AQ(2))+EXP(-AQ(2))) TS(2)=-SIN(AQ(1))*0.5*(EXP(+AQ(2))-EXP(-AQ(2))) TM(1)=SM(1)*TS(1)-SM(2)*TS(2) TM(2)=SM(1)*TS(2)+SM(2)*TS(1) TM(3)=SM(3)*TS(1)-SM(4)*TS(2) TM(4)=SM(3)*TS(2)+SM(4)*TS(1) TS(1)=+SIN(AQ(1))*0.5*(EXP(+AQ(2))+EXP(-AQ(2))) TS(2)=+COS(AQ(1))*0.5*(EXP(+AQ(2))-EXP(-AQ(2))) TM(1)=TM(1)-SM(3)*TS(1)+SM(4)*TS(2) TM(2)=TM(2)-SM(3)*TS(2)-SM(4)*TS(1) TM(3)=TM(3)+SM(1)*TS(1)-SM(2)*TS(2) TM(4)=TM(4)+SM(1)*TS(2)+SM(2)*TS(1) 105 IF(AZ(1))106,110,110 106 IF(AZ(2))107,108,108 107 SM(1)=-2.0*TM(1)+TM(4) SM(2)=-2.0*TM(2)-TM(3) GO TO 109 108 SM(1)=-2.0*TM(1)-TM(4) SM(2)=-2.0*TM(2)+TM(3) 109 IF(PN.EQ.0.0)GO TO 111 SM(1)=-SM(1) SM(2)=-SM(2) GO TO 111 110 SM(1)=TM(3) SM(2)=TM(4) 111 GO TO LA,(011,013,014) 112 SM(1)=1.0 SM(2)=0.0 SM(3)=1.0 SM(4)=0.0 M=15.0*PN+2.0 N=15.0*PN+15.0 DO 113 I=M,N TS(1)=+QZ(2)-CD(I) TS(2)=-QZ(1) SS=TS(1)*TS(1)+TS(2)*TS(2) TM(1)=+CE(I)*TS(1)/SS TM(2)=-CE(I)*TS(2)/SS SM(1)=SM(1)+TM(1) SM(2)=SM(2)+TM(2) TS(1)=-QZ(2)-CD(I) TS(2)=+QZ(1) SS=TS(1)*TS(1)+TS(2)*TS(2) TM(1)=+CE(I)*TS(1)/SS TM(2)=-CE(I)*TS(2)/SS SM(3)=SM(3)+TM(1) SM(4)=SM(4)+TM(2) 113 CONTINUE 114 AQ(1)=QZ(1)-1.57079632679490*(PN+0.5) AQ(2)=QZ(2) TS(1)=+COS(AQ(1))*0.5*(EXP(+AQ(2))+EXP(-AQ(2))) TS(2)=-SIN(AQ(1))*0.5*(EXP(+AQ(2))-EXP(-AQ(2))) TM(1)=+TS(1)*SM(1)-TS(2)*SM(2)+TS(1)*SM(3)-TS(2)*SM(4) TM(2)=+TS(1)*SM(2)+TS(2)*SM(1)+TS(1)*SM(4)+TS(2)*SM(3) TM(3)=+TS(1)*SM(2)+TS(2)*SM(1)-TS(1)*SM(4)-TS(2)*SM(3) TM(4)=-TS(1)*SM(1)+TS(2)*SM(2)+TS(1)*SM(3)-TS(2)*SM(4) TS(1)=+SIN(AQ(1))*0.5*(EXP(+AQ(2))+EXP(-AQ(2))) TS(2)=+COS(AQ(1))*0.5*(EXP(+AQ(2))-EXP(-AQ(2))) TM(1)=TM(1)-TS(1)*SM(2)-TS(2)*SM(1)+TS(1)*SM(4)+TS(2)*SM(3) TM(2)=TM(2)+TS(1)*SM(1)-TS(2)*SM(2)-TS(1)*SM(3)+TS(2)*SM(4) TM(3)=TM(3)+TS(1)*SM(1)-TS(2)*SM(2)+TS(1)*SM(3)-TS(2)*SM(4) TM(4)=TM(4)+TS(1)*SM(2)+TS(2)*SM(1)+TS(1)*SM(4)+TS(2)*SM(3) 115 IF(AZ(1))116,120,120 116 IF(AZ(2))117,118,118 117 SM(1)=-2.0*TM(1)+TM(4) SM(2)=-2.0*TM(2)-TM(3) GO TO 119 118 SM(1)=-2.0*TM(1)-TM(4) SM(2)=-2.0*TM(2)+TM(3) 119 IF(PN.EQ.0.0)GO TO 121 SM(1)=-SM(1) SM(2)=-SM(2) GO TO 121 120 SM(1)=TM(3) SM(2)=TM(4) 121 GO TO LR,(016,018,019) 122 AQ(1)=1.0 AQ(2)=0.0 RN=0.0 PM=0.0 GO TO 124 123 PM=PM+1.0 RN=RN+0.5/PM TS(1)=0.5*(AZ(1)*AQ(1)-AZ(2)*AQ(2)) TS(2)=0.5*(AZ(1)*AQ(2)+AZ(2)*AQ(1)) AQ(1)=TS(1)/PM AQ(2)=TS(2)/PM 124 IF(PM.LT.PN)GO TO 123 SZ(1)=0.25*(AZ(1)-AZ(2))*(AZ(1)+AZ(2)) SZ(2)=0.5*AZ(1)*AZ(2) SR(1)=0.0 SR(2)=0.0 SS=AQ(1)*AQ(1)+AQ(2)*AQ(2) TM(1)=+AQ(1)/SS TM(2)=-AQ(2)/SS PM=0.0 GO TO 126 125 TM(1)=TM(1)/(PN-PM) TM(2)=TM(2)/(PN-PM) SR(1)=SR(1)-0.5*TM(1) SR(2)=SR(2)-0.5*TM(2) PM=PM+1.0 TS(1)=SZ(1)*TM(1)-SZ(2)*TM(2) TS(2)=SZ(1)*TM(2)+SZ(2)*TM(1) TM(1)=+TS(1)/PM TM(2)=+TS(2)/PM 126 IF(PM.LT.PN)GO TO 125 SM(1)=0.0 SM(2)=0.0 RM=1.0 QM=0.0 SL(1)=-0.115931515658412+ZL(1)-RN SL(2)=+ZL(2) PM=0.0 GO TO 128 127 QM=QM+RM PM=PM+1.0 RM=0.25*ZS*RM/(PM*(PN+PM)) TS(1)=SZ(1)*AQ(1)-SZ(2)*AQ(2) TS(2)=SZ(1)*AQ(2)+SZ(2)*AQ(1) AQ(1)=-TS(1)/(PM*(PN+PM)) AQ(2)=-TS(2)/(PM*(PN+PM)) SL(1)=SL(1)-0.5/PM-0.5/(PN+PM) 128 TM(1)=AQ(1)*SL(1)-AQ(2)*SL(2) TM(2)=AQ(1)*SL(2)+AQ(2)*SL(1) SM(1)=SM(1)+TM(1) SM(2)=SM(2)+TM(2) IF(QM+RM.GT.QM)GO TO 127 SM(1)=SR(1)+SM(1) SM(2)=SR(2)+SM(2) GO TO LY,(022,024,025) END SUBROUTINE CBSSLI (Z, CNU, W) C------------------------------------------------------------ C CALCULATION OF THE MODIFIED BESSEL FUNCTION OF THE C FIRST KIND FOR COMPLEX ORDER CNU AND COMPLEX ARGUMENT C Z. IT IS ASSUMED THAT -PI .LT. ARG Z .LE. PI. C------------------------------------------------------------ COMPLEX Z, CNU, W, NU, Z0 C DATA PIHALF /1.5707963267949/ C X = REAL(Z) Y = AIMAG(Z) IF (Y .LT. 0.0) GO TO 10 Z0 = CMPLX(Y, -X) NU = CNU GO TO 20 10 Z0 = CMPLX(-Y, X) NU = -CNU C 20 T = -PIHALF*AIMAG(NU) IF (T .GT. EXPARG(1)) GO TO 30 W = (0.0, 0.0) RETURN C 30 CALL CBSSLJ (Z0, CNU, W) W = EXP(T)*W T = 0.5*REAL(NU) W = W*CMPLX(COS1(T),SIN1(T)) RETURN END SUBROUTINE BSSLI (MO, A, IN, W) C ****************************************************************** C FORTRAN SUBROUTINE FOR MODIFIED BESSEL FUNCTION OF INTEGRAL ORDER C ****************************************************************** C MO = MODE OF OPERATION C A = ARGUMENT (COMPLEX NUMBER) C IN = ORDER (INTEGER) C W = FUNCTION OF FIRST KIND (COMPLEX NUMBER) C ------------------- COMPLEX A, W DIMENSION AZ(2), FI(2) DIMENSION CD(30), CE(30) DIMENSION QZ(2), RZ(2), SZ(2), ZR(2) DIMENSION TS(2), TM(2), RM(4), SM(4), AQ(2), QF(2) DATA CD(1) / 0.00000000000000E00/, CD(2) /-1.64899505142212E-2/, 1 CD(3) /-7.18621880068536E-2/, CD(4) /-1.67086878124866E-1/, 2 CD(5) /-3.02582250219469E-1/, CD(6) /-4.80613945245927E-1/, 3 CD(7) /-7.07075239357898E-1/, CD(8) /-9.92995790539516E-1/, 4 CD(9) /-1.35583925612592E00/, CD(10)/-1.82105907899132E00/, 5 CD(11)/-2.42482175310879E00/, CD(12)/-3.21956655708750E00/, 6 CD(13)/-4.28658077248384E00/, CD(14)/-5.77022816798128E00/, 7 CD(15)/-8.01371260952526E00/ DATA CD(16)/ 0.00000000000000E00/, CD(17)/-5.57742429879505E-3/, 1 CD(18)/-4.99112944172476E-2/, CD(19)/-1.37440911652397E-1/, 2 CD(20)/-2.67233784710566E-1/, CD(21)/-4.40380166808682E-1/, 3 CD(22)/-6.61813614872541E-1/, CD(23)/-9.41861077665017E-1/, 4 CD(24)/-1.29754130468326E00/, CD(25)/-1.75407696719816E00/, 5 CD(26)/-2.34755299882276E00/, CD(27)/-3.13041332689196E00/, 6 CD(28)/-4.18397120563729E00/, CD(29)/-5.65251799214994E00/, 7 CD(30)/-7.87863959810677E00/ DATA CE(1) / 0.00000000000000E00/, CE(2) /-4.80942336387447E-3/, 1 CE(3) /-1.31366200347759E-2/, CE(4) /-1.94843834008458E-2/, 2 CE(5) /-2.19948900032003E-2/, CE(6) /-2.09396625676519E-2/, 3 CE(7) /-1.74600268458650E-2/, CE(8) /-1.27937813362085E-2/, 4 CE(9) /-8.05234421796592E-3/, CE(10)/-4.15817375002760E-3/, 5 CE(11)/-1.64317738747922E-3/, CE(12)/-4.49175585314709E-4/, 6 CE(13)/-7.28594765574007E-5/, CE(14)/-5.38265230658285E-6/, 7 CE(15)/-9.93779048036289E-8/ DATA CE(16)/ 0.00000000000000E00/, CE(17)/ 7.53805779200591E-2/, 1 CE(18)/ 7.12293537403464E-2/, CE(19)/ 6.33116224228200E-2/, 2 CE(20)/ 5.28240264523301E-2/, CE(21)/ 4.13305359441492E-2/, 3 CE(22)/ 3.01350573947510E-2/, CE(23)/ 2.01043439592720E-2/, 4 CE(24)/ 1.18552223068074E-2/, CE(25)/ 5.86055510956010E-3/, 5 CE(26)/ 2.25465148267325E-3/, CE(27)/ 6.08173041536336E-4/, 6 CE(28)/ 9.84215550625747E-5/, CE(29)/ 7.32139093038089E-6/, 7 CE(30)/ 1.37279667384666E-7/ C ------------------- AZ(1)=REAL(A) AZ(2)=AIMAG(A) ZS=AZ(1)*AZ(1)+AZ(2)*AZ(2) ZM=SQRT(ZS) PN=IABS(IN) SN=+1.0 IF(AZ(1))002,003,003 002 QZ(1)=-AZ(1) QZ(2)=-AZ(2) IF(IN.EQ.IN/2*2)GO TO 004 SN=-1.0 GO TO 004 003 QZ(1)=AZ(1) QZ(2)=AZ(2) 004 IF(ZM.LE.17.5+0.5*PN*PN)GO TO 005 QN=PN GO TO 011 005 QN=0.5*ZM-0.5*ABS(QZ(1))+0.5*ABS(0.5*ZM-ABS(QZ(1))) IF(PN.LE.QN)GO TO 006 QN=+AINT(0.0625*ZS) IF(PN.LE.QN)GO TO 039 QN=PN GO TO 039 006 IF(ZM.LE.17.5)GO TO 007 QN=+AINT(SQRT(2.0*(ZM-17.5))) GO TO 011 007 IF(ZS-1.0)009,008,008 008 IF(-ABS(AZ(1))+0.096*AZ(2)*AZ(2))009,010,010 009 QN=AINT(0.0625*ZS) IF(PN.LE.QN)GO TO 039 QN=PN GO TO 039 010 QN=0.0 011 SZ(1)=QZ(1) SZ(2)=QZ(2) QM=SN*0.398942280401433 ZR(1)=SQRT(SZ(1)+ZM) ZR(2)=SZ(2)/ZR(1) ZR(1)=0.707106781186548*ZR(1) ZR(2)=0.707106781186548*ZR(2) QF(1)=+QM*ZR(1)/ZM QF(2)=-QM*ZR(2)/ZM IF(ZM.LE.17.5)GO TO 017 012 RZ(1)=+0.5*QZ(1)/ZS RZ(2)=-0.5*QZ(2)/ZS AN=QN*QN-0.25 SM(1)=0.0 SM(2)=0.0 SM(3)=0.0 SM(4)=0.0 TM(1)=1.0 TM(2)=0.0 PM=0.0 GO TO 014 013 AN=AN-2.0*PM PM=PM+1.0 TS(1)=TM(1)*RZ(1)-TM(2)*RZ(2) TS(2)=TM(1)*RZ(2)+TM(2)*RZ(1) TM(1)=AN*TS(1)/PM TM(2)=AN*TS(2)/PM 014 SM(1)=SM(1)+TM(1) SM(2)=SM(2)+TM(2) AN=AN-2.0*PM PM=PM+1.0 TS(1)=TM(1)*RZ(1)-TM(2)*RZ(2) TS(2)=TM(1)*RZ(2)+TM(2)*RZ(1) TM(1)=AN*TS(1)/PM TM(2)=AN*TS(2)/PM IF(ABS(SM(3))+ABS(TM(1)).NE.ABS(SM(3)))GO TO 015 IF(ABS(SM(4))+ABS(TM(2)).EQ.ABS(SM(4)))GO TO 016 015 SM(3)=SM(3)+TM(1) SM(4)=SM(4)+TM(2) IF(PM.LT.35.0)GO TO 013 016 TS(1)=SM(1)+SM(3) TS(2)=SM(2)+SM(4) SM(1)=SM(1)-SM(3) SM(2)=SM(2)-SM(4) SM(3)=TS(1) SM(4)=TS(2) GO TO 019 017 SM(1)=1.0 SM(2)=0.0 SM(3)=1.0 SM(4)=0.0 M=15.0*QN+2.0 N=15.0*QN+15.0 DO 018 I=M,N TS(1)=-QZ(1)-CD(I) TS(2)=-QZ(2) SS=TS(1)*TS(1)+TS(2)*TS(2) TM(1)=+CE(I)*TS(1)/SS TM(2)=-CE(I)*TS(2)/SS SM(1)=SM(1)+TM(1) SM(2)=SM(2)+TM(2) TS(1)=QZ(1)-CD(I) TS(2)=QZ(2) SS=TS(1)*TS(1)+TS(2)*TS(2) TM(1)=+CE(I)*TS(1)/SS TM(2)=-CE(I)*TS(2)/SS SM(3)=SM(3)+TM(1) SM(4)=SM(4)+TM(2) 018 CONTINUE 019 RM(1)=SM(1) RM(2)=SM(2) IF(QZ(1).GE.17.5)GO TO 023 AQ(1)=-2.0*QZ(1) IF(QZ(2))020,021,021 020 AQ(2)=-2.0*QZ(2)-3.14159265358979*(QN+0.5) GO TO 022 021 AQ(2)=-2.0*QZ(2)+3.14159265358979*(QN+0.5) 022 QM=EXP(AQ(1)) TS(1)=QM*COS(AQ(2)) TS(2)=QM*SIN(AQ(2)) RM(1)=RM(1)+TS(1)*SM(3)-TS(2)*SM(4) RM(2)=RM(2)+TS(1)*SM(4)+TS(2)*SM(3) 023 IF(QN.EQ.PN)GO TO 037 RM(3)=RM(1) RM(4)=RM(2) QN=QN+1.0 IF(ZM.LE.17.5)GO TO 029 024 AN=QN*QN-0.25 SM(1)=0.0 SM(2)=0.0 SM(3)=0.0 SM(4)=0.0 TM(1)=1.0 TM(2)=0.0 PM=0.0 GO TO 026 025 AN=AN-2.0*PM PM=PM+1.0 TS(1)=TM(1)*RZ(1)-TM(2)*RZ(2) TS(2)=TM(1)*RZ(2)+TM(2)*RZ(1) TM(1)=AN*TS(1)/PM TM(2)=AN*TS(2)/PM 026 SM(1)=SM(1)+TM(1) SM(2)=SM(2)+TM(2) AN=AN-2.0*PM PM=PM+1.0 TS(1)=TM(1)*RZ(1)-TM(2)*RZ(2) TS(2)=TM(1)*RZ(2)+TM(2)*RZ(1) TM(1)=AN*TS(1)/PM TM(2)=AN*TS(2)/PM IF(ABS(SM(3))+ABS(TM(1)).NE.ABS(SM(3)))GO TO 027 IF(ABS(SM(4))+ABS(TM(2)).EQ.ABS(SM(4)))GO TO 028 027 SM(3)=SM(3)+TM(1) SM(4)=SM(4)+TM(2) IF(PM.LT.35.0)GO TO 025 028 TS(1)=SM(1)+SM(3) TS(2)=SM(2)+SM(4) SM(1)=SM(1)-SM(3) SM(2)=SM(2)-SM(4) SM(3)=TS(1) SM(4)=TS(2) GO TO 031 029 SM(1)=1.0 SM(2)=0.0 SM(3)=1.0 SM(4)=0.0 M=15.0*QN+2.0 N=15.0*QN+15.0 DO 030 I=M,N TS(1)=-QZ(1)-CD(I) TS(2)=-QZ(2) SS=TS(1)*TS(1)+TS(2)*TS(2) TM(1)=+CE(I)*TS(1)/SS TM(2)=-CE(I)*TS(2)/SS SM(1)=SM(1)+TM(1) SM(2)=SM(2)+TM(2) TS(1)=+QZ(1)-CD(I) TS(2)=+QZ(2) SS=TS(1)*TS(1)+TS(2)*TS(2) TM(1)=+CE(I)*TS(1)/SS TM(2)=-CE(I)*TS(2)/SS SM(3)=SM(3)+TM(1) SM(4)=SM(4)+TM(2) 030 CONTINUE 031 RM(1)=SM(1) RM(2)=SM(2) IF(QZ(1).GE.17.5)GO TO 036 AQ(1)=-2.0*QZ(1) IF(QZ(2))032,033,033 032 AQ(2)=-2.0*QZ(2)-3.14159265358979*(QN+0.5) GO TO 034 033 AQ(2)=-2.0*QZ(2)+3.14159265358979*(QN+0.5) 034 QM=EXP(AQ(1)) TS(1)=QM*COS(AQ(2)) TS(2)=QM*SIN(AQ(2)) RM(1)=RM(1)+TS(1)*SM(3)-TS(2)*SM(4) RM(2)=RM(2)+TS(1)*SM(4)+TS(2)*SM(3) GO TO 036 035 TM(1)=-2.0*QN*QZ(1)/ZS TM(2)=+2.0*QN*QZ(2)/ZS TS(1)=TM(1)*RM(1)-TM(2)*RM(2)+RM(3) TS(2)=TM(1)*RM(2)+TM(2)*RM(1)+RM(4) RM(3)=RM(1) RM(4)=RM(2) RM(1)=TS(1) RM(2)=TS(2) QN=QN+1.0 036 IF(QN.LT.PN)GO TO 035 037 IF(MO.NE.0)GO TO 038 QM=EXP(QZ(1)) TM(1)=QM*COS(QZ(2)) TM(2)=QM*SIN(QZ(2)) TS(1)=TM(1)*RM(1)-TM(2)*RM(2) TS(2)=TM(1)*RM(2)+TM(2)*RM(1) RM(1)=TS(1) RM(2)=TS(2) 038 FI(1)=QF(1)*RM(1)-QF(2)*RM(2) FI(2)=QF(1)*RM(2)+QF(2)*RM(1) W=CMPLX(FI(1),FI(2)) RETURN 039 SZ(1)=0.25*(QZ(1)*QZ(1)-QZ(2)*QZ(2)) SZ(2)=0.5*QZ(1)*QZ(2) AN=QN SM(1)=0.0 SM(2)=0.0 SM(3)=0.0 SM(4)=0.0 TM(1)=1.0 TM(2)=0.0 PM=0.0 040 AN=AN+1.0 TS(1)=TM(1)/AN TS(2)=TM(2)/AN SM(3)=SM(3)+TS(1) SM(4)=SM(4)+TS(2) TM(1)=TS(1)*SZ(1)-TS(2)*SZ(2) TM(2)=TS(1)*SZ(2)+TS(2)*SZ(1) PM=PM+1.0 TM(1)=TM(1)/PM TM(2)=TM(2)/PM IF(ABS(SM(1))+ABS(TM(1)).NE.ABS(SM(1)))GO TO 041 IF(ABS(SM(2))+ABS(TM(2)).EQ.ABS(SM(2)))GO TO 042 041 SM(1)=SM(1)+TM(1) SM(2)=SM(2)+TM(2) GO TO 040 042 SM(1)=SM(1)+1.0 AN=QN+1.0 SM(3)=AN*SM(3) SM(4)=AN*SM(4) GO TO 044 043 AN=QN*(QN+1.0) TM(1)=SZ(1)/AN TM(2)=SZ(2)/AN TS(1)=+TM(1)*SM(3)-TM(2)*SM(4) TS(2)=+TM(1)*SM(4)+TM(2)*SM(3) SM(3)=SM(1) SM(4)=SM(2) SM(1)=SM(1)+TS(1) SM(2)=SM(2)+TS(2) QN=QN-1.0 044 IF(QN.GT.PN)GO TO 043 QF(1)=SN QF(2)=0.0 QN=0.0 GO TO 046 045 QN=QN+1.0 TM(1)=QF(1)*QZ(1)-QF(2)*QZ(2) TM(2)=QF(1)*QZ(2)+QF(2)*QZ(1) QF(1)=0.5*TM(1)/QN QF(2)=0.5*TM(2)/QN 046 IF(QN.LT.PN)GO TO 045 IF(MO.EQ.0)GO TO 047 QM=EXP(-QZ(1)) TM(1)=QM*COS(-QZ(2)) TM(2)=QM*SIN(-QZ(2)) TS(1)=TM(1)*QF(1)-TM(2)*QF(2) TS(2)=TM(1)*QF(2)+TM(2)*QF(1) QF(1)=TS(1) QF(2)=TS(2) 047 FI(1)=QF(1)*SM(1)-QF(2)*SM(2) FI(2)=QF(1)*SM(2)+QF(2)*SM(1) W=CMPLX(FI(1),FI(2)) RETURN END SUBROUTINE BESI(X, ALPHA, KODE, N, Y, NZ) C C WRITTEN BY D. E. AMOS AND S. L. DANIEL, JANUARY,1975. C C REFERENCE C SAND-75-0152 C C CDC 6600 SUBROUTINES IBESS AND JBESS FOR BESSEL FUNCTIONS C I(NU,X) AND J(NU,X), X.GE.0, NU.GE.0 BY D.E. AMOS, S.L. C DANIEL, M.K. WESTON. ACM TRANS MATH SOFTWARE,3,PP 76-92 C (1977) C C TABLES OF BESSEL FUNCTIONS OF MODERATE OR LARGE ORDERS, C NPL MATHEMATICAL TABLES, VOL. 6, BY F.W.J. OLVER, HER C MAJESTY-S STATIONERY OFFICE, LONDON, 1962. C C ABSTRACT C BESI COMPUTES AN N MEMBER SEQUENCE OF I BESSEL FUNCTIONS C I/SUB(ALPHA+K-1)/(X), K=1,...,N OR SCALED BESSEL FUNCTIONS C EXP(-X)*I/SUB(ALPHA+K-1)/(X), K=1,...,N FOR NON-NEGATIVE ALPHA C AND X. A COMBINATION OF THE POWER SERIES, THE ASYMPTOTIC C EXPANSION FOR X TO INFINITY, AND THE UNIFORM ASYMPTOTIC C EXPANSION FOR NU TO INFINITY ARE APPLIED OVER SUBDIVISIONS OF C THE (NU,X) PLANE. FOR VALUES NOT COVERED BY ONE OF THESE C FORMULAE, THE ORDER IS INCREMENTED BY AN INTEGER SO THAT ONE C OF THESE FORMULAE APPLY. BACKWARD RECURSION IS USED TO REDUCE C ORDERS BY INTEGER VALUES. THE ASYMPTOTIC EXPANSION FOR X TO C INFINITY IS USED ONLY WHEN THE ENTIRE SEQUENCE (SPECIFICALLY C THE LAST MEMBER) LIES WITHIN THE REGION COVERED BY THE C EXPANSION. LEADING TERMS OF THESE EXPANSIONS ARE USED TO TEST C FOR OVER OR UNDERFLOW WHERE APPROPRIATE. IF A SEQUENCE IS C REQUESTED AND THE LAST MEMBER WOULD UNDERFLOW, THE RESULT IS C SET TO ZERO AND THE NEXT LOWER ORDER TRIED, ETC., UNTIL A C MEMBER COMES ON SCALE OR ALL ARE SET TO ZERO. AN OVERFLOW C CANNOT OCCUR WITH SCALING. C C BESI CALLS ASIK, GAMLN, SPMPAR, AND IPMPAR C C DESCRIPTION OF ARGUMENTS C C INPUT C X - X.GE.0.0E0 C ALPHA - ORDER OF FIRST MEMBER OF THE SEQUENCE, C ALPHA.GE.0.0E0 C KODE - A PARAMETER TO INDICATE THE SCALING OPTION C KODE=1 RETURNS C Y(K)= I/SUB(ALPHA+K-1)/(X), C K=1,...,N C KODE=2 RETURNS C Y(K)=EXP(-X)*I/SUB(ALPHA+K-1)/(X), C K=1,...,N C N - NUMBER OF MEMBERS IN THE SEQUENCE, N.GE.1 C C OUTPUT C Y - A VECTOR WHOSE FIRST N COMPONENTS CONTAIN C VALUES FOR I/SUB(ALPHA+K-1)/(X) OR SCALED C VALUES FOR EXP(-X)*I/SUB(ALPHA+K-1)/(X), C K=1,...,N DEPENDING ON KODE C NZ - ERROR INDICATOR C NZ= 0 NORMAL RETURN-COMPUTATION COMPLETED C NZ=-1 X IS LESS THAN 0.0 C NZ=-2 ALPHA IS LESS THAN 0.0 C NZ=-3 N IS LESS THAN 1 C NZ=-4 KODE IS NOT 1 OR 2 C NZ=-5 X IS TOO LARGE FOR KODE=1 C NZ.GT.0 LAST NZ COMPONENTS OF Y SET TO 0.0 C BECAUSE OF UNDERFLOW C C ERROR CONDITIONS C IMPROPER INPUT ARGUMENTS - A FATAL ERROR C OVERFLOW WITH KODE=1 - A FATAL ERROR C UNDERFLOW - A NON-FATAL ERROR(NZ.GT.0) C INTEGER I, IALP, IN, INLIM, IS, I1, I2, K, KK, KM, KODE, KT, * N, NN, NS, NZ INTEGER IPMPAR REAL AIN, AK, AKM, ALPHA, ANS, AP, ARG, ATOL, TOLLN, DFN, * DTM, DX, EARG, ELIM, ETX, FLGIK,FN, FNF, FNI,FNP1,FNU,GLN,RA, * RTTPI, S, SX, SXO2, S1, S2, T, TA, TB, TEMP, TFN, TM, TOL, * TRX, T2, X, XO2, XO2L, Y, Z REAL GAMLN, SPMPAR DIMENSION Y(N), TEMP(3) DATA RTTPI / 3.98942280401433E-01/ DATA INLIM / 80 / C ------------------- C IPMPAR(8) REPLACES IPMPAR(5) IN A DOUBLE PRECISION CODE C IPMPAR(9) REPLACES IPMPAR(6) IN A DOUBLE PRECISION CODE C C DEFINITION OF THE TOLERANCES TOL AND ELIM C TB = IPMPAR(4) TA = SPMPAR(1)/TB IF (TB.EQ.2.0E0) GO TO 1 IF (TB.EQ.8.0E0) GO TO 2 IF (TB.EQ.16.0E0) GO TO 3 TB = ALOG(TB) GO TO 5 1 TB = .69315E0 GO TO 5 2 TB = 2.07944E0 GO TO 5 3 TB = 2.77259E0 C 5 TOL = AMAX1(TA,1.E-15) I1 = IPMPAR(5) I2 = IPMPAR(6) C LN(10**3) = 6.90776 ELIM = FLOAT(-I2)*TB - 6.90776E0 C TOLLN = -LN(TOL) TOLLN = FLOAT(I1)*TB TOLLN = AMIN1(TOLLN,34.5388E0) C C C NZ = 0 KT = 1 IF (N-1) 590, 10, 20 10 KT = 2 20 NN = N IF (KODE.LT.1 .OR. KODE.GT.2) GO TO 570 IF (X) 600, 30, 80 30 IF (ALPHA) 580, 40, 50 40 Y(1) = 1.0E0 IF (N.EQ.1) RETURN I1 = 2 GO TO 60 50 I1 = 1 60 DO 70 I=I1,N Y(I) = 0.0E0 70 CONTINUE RETURN 80 CONTINUE IF (ALPHA.LT.0.0E0) GO TO 580 C IALP = INT(ALPHA) FNI = FLOAT(IALP+N-1) FNF = ALPHA - FLOAT(IALP) DFN = FNI + FNF FNU = DFN IN = 0 XO2 = X*0.5E0 SXO2 = XO2*XO2 ETX = FLOAT(KODE-1) SX = ETX*X C C DECISION TREE FOR REGION WHERE SERIES, ASYMPTOTIC EXPANSION FOR X C TO INFINITY AND ASYMPTOTIC EXPANSION FOR NU TO INFINITY ARE C APPLIED. C IF (SXO2.LE.(FNU+1.0E0)) GO TO 90 IF (X.LE.12.0E0) GO TO 110 FN = 0.55E0*FNU*FNU FN = AMAX1(17.0E0,FN) IF (X.GE.FN) GO TO 430 ANS = AMAX1(36.0E0-FNU,0.0E0) NS = INT(ANS) FNI = FNI + FLOAT(NS) DFN = FNI + FNF FN = DFN IS = KT KM = N - 1 + NS IF (KM.GT.0) IS = 3 GO TO 120 90 FN = FNU FNP1 = FN + 1.0E0 XO2L = ALOG(XO2) IS = KT IF (X.LE.0.5E0) GO TO 230 NS = 0 100 FNI = FNI + FLOAT(NS) DFN = FNI + FNF FN = DFN FNP1 = FN + 1.0E0 IS = KT IF (N-1+NS.GT.0) IS = 3 GO TO 230 110 XO2L = ALOG(XO2) NS = INT(SXO2-FNU) GO TO 100 120 CONTINUE C C OVERFLOW TEST ON UNIFORM ASYMPTOTIC EXPANSION C IF (KODE.EQ.2) GO TO 130 IF (ALPHA.LT.1.0E0) GO TO 150 Z = X/ALPHA RA = SQRT(1.0E0+Z*Z) GLN = ALOG((1.0E0+RA)/Z) T = RA*(1.0E0-ETX) + ETX/(Z+RA) ARG = ALPHA*(T-GLN) IF (ARG.GT.ELIM) GO TO 610 IF (KM.EQ.0) GO TO 140 130 CONTINUE C C UNDERFLOW TEST ON UNIFORM ASYMPTOTIC EXPANSION C Z = X/FN RA = SQRT(1.0E0+Z*Z) GLN = ALOG((1.0E0+RA)/Z) T = RA*(1.0E0-ETX) + ETX/(Z+RA) ARG = FN*(T-GLN) 140 IF (ARG.LT.(-ELIM)) GO TO 280 GO TO 190 150 IF (X.GT.ELIM) GO TO 610 GO TO 130 C C UNIFORM ASYMPTOTIC EXPANSION FOR NU TO INFINITY C 160 IF (KM.NE.0) GO TO 170 Y(1) = TEMP(3) RETURN 170 TEMP(1) = TEMP(3) IN = NS KT = 1 I1 = 0 180 CONTINUE IS = 2 FNI = FNI - 1.0E0 DFN = FNI + FNF FN = DFN IF(I1.EQ.2) GO TO 350 Z = X/FN RA = SQRT(1.0E0+Z*Z) GLN = ALOG((1.0E0+RA)/Z) T = RA*(1.0E0-ETX) + ETX/(Z+RA) ARG = FN*(T-GLN) 190 CONTINUE I1 = IABS(3-IS) I1 = MAX0(I1,1) FLGIK = 1.0E0 CALL ASIK(X,FN,KODE,FLGIK,RA,ARG,I1,TOL,TEMP(IS)) GO TO (180, 350, 510), IS C C SERIES FOR (X/2)**2.LE.NU+1 C 230 CONTINUE GLN = GAMLN(FNP1) ARG = FN*XO2L - GLN - SX IF (ARG.LT.(-ELIM)) GO TO 300 EARG = EXP(ARG) 240 CONTINUE S = 1.0E0 IF (X.LT.TOL) GO TO 260 AK = 3.0E0 T2 = 1.0E0 T = 1.0E0 S1 = FN DO 250 K=1,17 S2 = T2 + S1 T = T*SXO2/S2 S = S + T IF (ABS(T).LT.TOL) GO TO 260 T2 = T2 + AK AK = AK + 2.0E0 S1 = S1 + FN 250 CONTINUE 260 CONTINUE TEMP(IS) = S*EARG GO TO (270, 350, 500), IS 270 EARG = EARG*FN/XO2 FNI = FNI - 1.0E0 DFN = FNI + FNF FN = DFN IS = 2 GO TO 240 C C SET UNDERFLOW VALUE AND UPDATE PARAMETERS C 280 Y(NN) = 0.0E0 NN = NN - 1 FNI = FNI - 1.0E0 DFN = FNI + FNF FN = DFN IF (NN-1) 340, 290, 130 290 KT = 2 IS = 2 GO TO 130 300 Y(NN) = 0.0E0 NN = NN - 1 FNP1 = FN FNI = FNI - 1.0E0 DFN = FNI + FNF FN = DFN IF (NN-1) 340, 310, 320 310 KT = 2 IS = 2 320 IF (SXO2.LE.FNP1) GO TO 330 GO TO 130 330 ARG = ARG - XO2L + ALOG(FNP1) IF (ARG.LT.(-ELIM)) GO TO 300 GO TO 230 340 NZ = N - NN RETURN C C BACKWARD RECURSION SECTION C 350 CONTINUE NZ = N - NN 360 CONTINUE IF(KT.EQ.2) GO TO 420 S1 = TEMP(1) S2 = TEMP(2) TRX = 2.0E0/X DTM = FNI TM = (DTM+FNF)*TRX IF (IN.EQ.0) GO TO 390 C BACKWARD RECUR TO INDEX ALPHA+NN-1 DO 380 I=1,IN S = S2 S2 = TM*S2 + S1 S1 = S DTM = DTM - 1.0E0 TM = (DTM+FNF)*TRX 380 CONTINUE Y(NN) = S1 IF (NN.EQ.1) RETURN Y(NN-1) = S2 IF (NN.EQ.2) RETURN GO TO 400 390 CONTINUE C BACKWARD RECUR FROM INDEX ALPHA+NN-1 TO ALPHA Y(NN) = S1 Y(NN-1) = S2 IF (NN.EQ.2) RETURN 400 K = NN + 1 DO 410 I=3,NN K = K - 1 Y(K-2) = TM*Y(K-1) + Y(K) DTM = DTM - 1.0E0 TM = (DTM+FNF)*TRX 410 CONTINUE RETURN 420 Y(1) = TEMP(2) RETURN C C ASYMPTOTIC EXPANSION FOR X TO INFINITY C 430 CONTINUE EARG = RTTPI/SQRT(X) IF (KODE.EQ.2) GO TO 440 IF (X.GT.ELIM) GO TO 610 EARG = EARG*EXP(X) 440 ETX = 8.0E0*X IS = KT IN = 0 FN = FNU 450 DX = FNI + FNI TM = 0.0E0 IF (FNI.EQ.0.0E0 .AND. ABS(FNF).LT.TOL) GO TO 460 TM = 4.0E0*FNF*(FNI+FNI+FNF) 460 CONTINUE DTM = DX*DX S1 = ETX TRX = DTM - 1.0E0 DX = -(TRX+TM)/ETX T = DX S = 1.0E0 + DX ATOL = TOL*ABS(S) S2 = 1.0E0 AK = 8.0E0 DO 470 K=1,25 S1 = S1 + ETX S2 = S2 + AK DX = DTM - S2 AP = DX + TM T = -T*AP/S1 S = S + T IF (ABS(T).LE.ATOL) GO TO 480 AK = AK + 8.0E0 470 CONTINUE 480 TEMP(IS) = S*EARG IF(IS.EQ.2) GO TO 360 IS = 2 FNI = FNI - 1.0E0 DFN = FNI + FNF FN = DFN GO TO 450 C C BACKWARD RECURSION WITH NORMALIZATION BY C ASYMPTOTIC EXPANSION FOR NU TO INFINITY OR POWER SERIES. C 500 CONTINUE C COMPUTATION OF LAST ORDER FOR SERIES NORMALIZATION AKM = AMAX1(3.0E0-FN,0.0E0) KM = INT(AKM) TFN = FN + FLOAT(KM) TA = (GLN+TFN-0.9189385332E0-0.0833333333E0/TFN)/(TFN+0.5E0) TA = XO2L - TA TB = -(1.0E0-1.0E0/TFN)/TFN AIN = TOLLN/(-TA+SQRT(TA*TA-TOLLN*TB)) + 1.5E0 IN = INT(AIN) IN = IN + KM GO TO 520 510 CONTINUE C COMPUTATION OF LAST ORDER FOR ASYMPTOTIC EXPANSION NORMALIZATION T = 1.0E0/(FN*RA) AIN = TOLLN/(GLN+SQRT(GLN*GLN+T*TOLLN)) + 1.5E0 IN = INT(AIN) IF (IN.GT.INLIM) GO TO 160 520 CONTINUE TRX = 2.0E0/X DTM = FNI + FLOAT(IN) TM = (DTM+FNF)*TRX TA = 0.0E0 TB = TOL KK = 1 530 CONTINUE C C BACKWARD RECUR UNINDEXED C DO 540 I=1,IN S = TB TB = TM*TB + TA TA = S DTM = DTM - 1.0E0 TM = (DTM+FNF)*TRX 540 CONTINUE C NORMALIZATION IF (KK.NE.1) GO TO 550 TA = (TA/TB)*TEMP(3) TB = TEMP(3) KK = 2 IN = NS IF (NS.NE.0) GO TO 530 550 Y(NN) = TB NZ = N - NN IF (NN.EQ.1) RETURN TB = TM*TB + TA K = NN - 1 Y(K) = TB IF (NN.EQ.2) RETURN DTM = DTM - 1.0E0 TM = (DTM+FNF)*TRX KM = K - 1 C C BACKWARD RECUR INDEXED C DO 560 I=1,KM Y(K-1) = TM*Y(K) + Y(K+1) DTM = DTM - 1.0E0 TM = (DTM+FNF)*TRX K = K - 1 560 CONTINUE RETURN C C C 570 CONTINUE NZ = -4 RETURN 580 CONTINUE NZ = -2 RETURN 590 CONTINUE NZ = -3 RETURN 600 CONTINUE NZ = -1 RETURN 610 CONTINUE NZ = -5 RETURN END SUBROUTINE ASIK(X,FNU,KODE,FLGIK,RA,ARG,IN,TOL,Y) C C ASIK COMPUTES BESSEL FUNCTIONS I AND K C FOR ARGUMENTS X.GT.0.0 AND ORDERS FNU.GE.35 C ON FLGIK = 1 AND FLGIK = -1 RESPECTIVELY. C C INPUT C C X - ARGUMENT, X.GT.0.0E0 C FNU - ORDER OF FIRST BESSEL FUNCTION C KODE - A PARAMETER TO INDICATE THE SCALING OPTION C KODE=1 RETURNS Y(I)= I/SUB(FNU+I-1)/(X), I=1,IN C OR Y(I)= K/SUB(FNU+I-1)/(X), I=1,IN C ON FLGIK = 1.0E0 OR FLGIK = -1.0E0 C KODE=2 RETURNS Y(I)=EXP(-X)*I/SUB(FNU+I-1)/(X), I=1,IN C OR Y(I)=EXP( X)*K/SUB(FNU+I-1)/(X), I=1,IN C ON FLGIK = 1.0E0 OR FLGIK = -1.0E0 C FLGIK - SELECTION PARAMETER FOR I OR K FUNCTION C FLGIK = 1.0E0 GIVES THE I FUNCTION C FLGIK = -1.0E0 GIVES THE K FUNCTION C RA - SQRT(1.+Z*Z), Z=X/FNU C ARG - ARGUMENT OF THE LEADING EXPONENTIAL C IN - NUMBER OF FUNCTIONS DESIRED, IN=1 OR 2 C TOL - TOLERANCE SPECIFIED BY BESI OR BESK C C OUTPUT C C Y - A VECTOR WHOSE FIRST IN COMPONENTS CONTAIN THE SEQUENCE C C WRITTEN BY C D. E. AMOS C C ABSTRACT C ASIK IMPLEMENTS THE UNIFORM ASYMPTOTIC EXPANSION OF C THE I AND K BESSEL FUNCTIONS FOR FNU.GE.35 AND REAL C X.GT.0.0E0. THE FORMS ARE IDENTICAL EXCEPT FOR A CHANGE C IN SIGN OF SOME OF THE TERMS. THIS CHANGE IN SIGN IS C ACCOMPLISHED BY MEANS OF THE FLAG FLGIK = 1 OR -1. C INTEGER IN, J, JN, K, KK, KODE, L REAL AK,AP,ARG,C, COEF,CON,ETX,FLGIK,FN, FNU,GLN,RA,S1,S2, * T, TOL, T2, X, Y, Z DIMENSION Y(*), C(65), CON(2) DATA CON(1), CON(2) / 1 3.98942280401432678E-01, 1.25331413731550025E+00/ DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), 1 C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), 2 C(19), C(20), C(21), C(22), C(23), C(24)/ 3 -2.08333333333333E-01, 1.25000000000000E-01, 4 3.34201388888889E-01, -4.01041666666667E-01, 5 7.03125000000000E-02, -1.02581259645062E+00, 6 1.84646267361111E+00, -8.91210937500000E-01, 7 7.32421875000000E-02, 4.66958442342625E+00, 8 -1.12070026162230E+01, 8.78912353515625E+00, 9 -2.36408691406250E+00, 1.12152099609375E-01, A -2.82120725582002E+01, 8.46362176746007E+01, B -9.18182415432400E+01, 4.25349987453885E+01, C -7.36879435947963E+00, 2.27108001708984E-01, D 2.12570130039217E+02, -7.65252468141182E+02, E 1.05999045252800E+03, -6.99579627376133E+02/ DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), 1 C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), 2 C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ 3 2.18190511744212E+02, -2.64914304869516E+01, 4 5.72501420974731E-01, -1.91945766231841E+03, 5 8.06172218173731E+03, -1.35865500064341E+04, 6 1.16553933368645E+04, -5.30564697861340E+03, 7 1.20090291321635E+03, -1.08090919788395E+02, 8 1.72772750258446E+00, 2.02042913309661E+04, 9 -9.69805983886375E+04, 1.92547001232532E+05, A -2.03400177280416E+05, 1.22200464983017E+05, B -4.11926549688976E+04, 7.10951430248936E+03, C -4.93915304773088E+02, 6.07404200127348E+00, D -2.42919187900551E+05, 1.31176361466298E+06, E -2.99801591853811E+06, 3.76327129765640E+06/ DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), 1 C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), 2 C(65)/ 3 -2.81356322658653E+06, 1.26836527332162E+06, 4 -3.31645172484564E+05, 4.52187689813627E+04, 5 -2.49983048181121E+03, 2.43805296995561E+01, 6 3.28446985307204E+06, -1.97068191184322E+07, 7 5.09526024926646E+07, -7.41051482115327E+07, 8 6.63445122747290E+07, -3.75671766607634E+07, 9 1.32887671664218E+07, -2.78561812808645E+06, A 3.08186404612662E+05, -1.38860897537170E+04, B 1.10017140269247E+02/ C --------------------- FN = FNU Z = (3.0E0-FLGIK)/2.0E0 KK = INT(Z) DO 50 JN=1,IN IF (JN.EQ.1) GO TO 10 FN = FN - FLGIK Z = X/FN RA = SQRT(1.0E0+Z*Z) GLN = ALOG((1.0E0+RA)/Z) ETX = FLOAT(KODE-1) T = RA*(1.0E0-ETX) + ETX/(Z+RA) ARG = FN*(T-GLN)*FLGIK 10 COEF = EXP(ARG) T = 1.0E0/RA T2 = T*T T = T/FN T = SIGN(T,FLGIK) S2 = 1.0E0 AP = 1.0E0 L = 0 DO 30 K=2,11 L = L + 1 S1 = C(L) DO 20 J=2,K L = L + 1 S1 = S1*T2 + C(L) 20 CONTINUE AP = AP*T AK = AP*S1 S2 = S2 + AK IF (AMAX1(ABS(AK),ABS(AP)) .LT. TOL) GO TO 40 30 CONTINUE 40 CONTINUE T = ABS(T) Y(JN) = S2*COEF*SQRT(T)*CON(KK) 50 CONTINUE RETURN END SUBROUTINE CBESK (Z, CNU, W) C----------------------------------------------------------------------- C C CALCULATION OF THE MODIFIED BESSEL FUNCTION OF THE C SECOND KIND FOR COMPLEX ORDER CNU AND COMPLEX ARGUMENT C Z. IT IS ASSUMED THAT -PI .LT. ARG Z .LE. PI. C C----------------------------------------------------------------------- C WRITTEN BY C ALFRED H. MORRIS, JR. AND ANDREW H. VAN TUYL C NAVAL SURFACE WARFARE CENTER C OCT 1992 C-------------------------- COMPLEX Z, CNU, W COMPLEX NU C X = ABS(REAL(Z)) Y = ABS(AIMAG(Z)) NU = CNU IF (REAL(NU) .LT. 0.0) NU = - NU A = REAL(NU) B = ABS(AIMAG(NU)) RN = CPABS(A, B) RZ = CPABS(X, Y) C C ASYMPTOTIC EXPANSION C IF (RZ .LT. 17.5 + 0.5*RN*RN) GO TO 10 CALL CBKA (Z, NU, W) RETURN C 10 IF (B .LE. 1.5E-2*A) GO TO 200 TAU = RN/RZ IF (TAU .GE. 1.5) GO TO 100 IF (TAU .LE. 0.05) GO TO 200 IF (TAU .LT. 0.70 .AND. REAL(Z) .LE. 0.0) GO TO 100 IF (AIMAG(NU) .GT. 0.0 .AND. B .LT. 0.07*A) GO TO 200 C IF (TAU .LT. 1.291) GO TO 20 IF (AIMAG(NU) .LT. 0.0 .AND. B .LT. 0.127*A) GO TO 40 S = 0.5*(1.5 - TAU) IF (B .LT. S*A) GO TO 200 GO TO 100 C 20 IF (TAU .LT. 0.639) GO TO 60 IF (TAU .GT. 0.691) GO TO 30 IF (B .GT. 0.5*A) GO TO 61 E = B/A GO TO 50 C 30 IF (B .LT. 0.191*A) GO TO 40 IF (TAU .GT. 0.99 .AND. B .GT. 0.257*A .AND. * B .LT. 0.64*A) GO TO 61 IF (TAU .LE. 1.16 .AND. B .LT. 0.727*A .AND. * Y .LT. 0.727*X) GO TO 200 IF (TAU .LE. 0.91 .AND. A .GT. 0.45*B .AND. * Y .LT. 0.325*X) GO TO 200 C = 0.471 IF (TAU .LT. 0.75) C = 0.55 IF (TAU .LT. 0.844 .AND. A .LT. 0.55*B .AND. * Y .LT. C*X) GO TO 200 C 40 S = 1.65*(1.54 - TAU)**2 IF (TAU .LT. 0.91) S = 0.82 - 1.5*(TAU - 0.8) E = 2.25 IF (TAU .LT. 0.78) E = 2.90 IF (B .GT. E*S*A) GO TO 100 IF (B .GT. 0.5*A) GO TO 61 C E = B/(S*A) IF (E .LT. 0.50) GO TO 50 C = 2.83 - 1.66*E IF (Y .GT. C*X) GO TO 100 GO TO 200 50 C = 7.0 - 10.0*E IF (TAU .GT. 0.86) C = 8.0 - 12.0*E IF (Y .GT. C*X) GO TO 100 GO TO 200 C 60 IF (B .LE. 0.191*A) GO TO 200 61 IF (X .LT. 0.64*(TAU - 0.2)*Y) GO TO 100 S = 1.5*B/(A + 1.E-7) E = 0.95 IF (TAU .GT. 0.95 .AND. TAU .LT. 1.16 .AND. * B .GT. 0.471*A .AND. B .LE. A) E = 0.75 IF (TAU .GT. 0.85 .AND. TAU .LE. 0.95 .AND. * B .LE. A) E = 0.80 IF (TAU .GT. 0.71 .AND. TAU .LE. 0.85 .AND. * B .LT. 1.21*A) E = 0.85 IF (TAU .GT. 0.61 .AND. TAU .LE. 0.71 .AND. * B .GT. 0.63*A .AND. B .LT. 1.15*A) E = 0.80 IF (TAU .GT. 0.50 .AND. TAU .LE. 0.61 .AND. * B .GT. 0.7*A .AND. B .LE. A) E = 0.70 C IF (TAU .GT. 0.68 .AND. TAU .LE. 0.77 .AND. * A .LT. 0.75*B) E = 1.15 IF (TAU .GT. 0.77 .AND. TAU .LT. 0.95 .AND. * A .LT. 0.83*B) E = 1.10 C = (1.0 + E*TAU)*TAU*TANH(S)**2 IF (X .GE. C*Y) GO TO 200 C C CALCULATION IN TERMS OF THE MODIFIED C BESSEL FUNCTION I C 100 CALL CBKI (Z, NU, W) RETURN C C POWER SERIES AND MILLER ALGORITHM C 200 CALL CBKM (Z, RZ, NU, W) RETURN END SUBROUTINE CBKI (Z, CNU, W) C------------------------------------------------------------ C CALCULATION OF THE MODIFIED BESSEL FUNCTION OF THE C SECOND KIND WITH COMPLEX ORDER AND ARGUMENT IN TERMS C OF THE MODIFIED BESSEL FUNCTION OF THE FIRST KIND. C------------------------------------------------------------ COMPLEX Z, CNU, W, W1, W2 COMPLEX CDIV C DATA PI/3.14159265358979E+00/ DATA PIHALF/1.5707963267949E+00/ C CALL CBSSLI (Z, -CNU, W1) CALL CBSSLI (Z, CNU, W2) A = REAL(CNU) B = PI*AIMAG(CNU) U1 = SIN1(A)*COSH(B) U2 = COS1(A)*SINH(B) W = PIHALF*CDIV(W1 - W2, CMPLX(U1,U2)) RETURN END SUBROUTINE CBKA (Z, CNU, W) C----------------------------------------------------------------------- C COMPUTATION OF THE BESSEL FUNCTION K FOR COMPLEX ORDER C CNU AND COMPLEX ARGUMENT Z BY THE ASYMPTOTIC EXPANSION C----------------------------------------------------------------------- COMPLEX Z, CNU, W REAL M COMPLEX A, P, T, ZR C-------------------------- ANORM(Z) = AMAX1(ABS(REAL(Z)), ABS(AIMAG(Z))) C-------------------------- C C = PI**(1/2) C-------------------------- DATA C /1.77245385090552E+00/ C-------------------------- C C ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE C SMALLEST NUMBER SUCH THAT 1.0 + EPS .GT. 1.0 . C EPS = SPMPAR(1) C C-------------------------- CALL CREC (REAL(Z), AIMAG(Z), U, V) ZR = CMPLX(0.5*U, 0.5*V) A = CNU*CNU - 0.25 M = 1.0 T = A*ZR P = T C DO 10 I = 1, 16 A = A - 2.0*M M = M + 1.0 T = T*A*ZR/M P = P + T IF (ANORM(T) .LE. EPS*ANORM(P)) GO TO 20 10 CONTINUE C 20 P = P + 1.0 T = CSQRT(ZR) IF (AIMAG(Z) .EQ. 0.0) T = CONJG(T) W = C*T*P*CEXP(-Z) RETURN END SUBROUTINE CBKM (Z, RZ, CNU, W) C------------------------------------------------------------------- C CALCULATION OF THE MODIFIED BESSEL FUNCTION OF THE SECOND C KIND WITH COMPLEX ORDER AND ARGUMENT BY MEANS OF MACLAURIN C EXPANSIONS AND THE MILLER ALGORITHM. IT IS ASSUMED THAT C RZ = ABS(Z). C------------------------------------------------------------------- COMPLEX Z, CNU, W REAL NU COMPLEX CZ, EX, R, R1, U1, U2, U3, W1, W2, ZR COMPLEX CXP C--------------------------- C CPI = SQRT(PI/2) C--------------------------- DATA PI /3.14159265358979/ DATA CPI /1.25331413731550/ C C REDUCTION OF CNU TO R = NU + B*I WHERE C -0.5 .LT. NU .LE. 0.5 C R = CNU IF (REAL(R) .LT. 0.0) R = - R C A = REAL(R) B = AIMAG(R) N = A NU = A - FLOAT(N) T = NU - 0.5 IF (T .LE. 0.0) GO TO 10 NU = T - 0.5 N = N + 1 10 M = N R1 = CMPLX(NU, B) C IND = 1 CZ = Z X = 0.5*REAL(Z) Y = 0.5*AIMAG(Z) CALL CREC (X, Y, ZR1, ZR2) ZR = CMPLX (ZR1, ZR2) IF (T .NE. 0.0) GO TO 20 IF (B .NE. 0.0) GO TO 20 C C CALCULATION FOR NU = 0.5 C W = CMPLX(CPI, 0.0) W1 = (1.0, 0.0) IF (N .EQ. 0) GO TO 90 IF (X .GE. 0.0) GO TO 15 IND = -1 CZ = - Z ZR = - ZR 15 U1 = W U2 = W N = N + 1 R1 = (-0.5, 0.0) GO TO 70 C C CALCULATION FOR ABS(NU) .LT. 0.5 C 20 ZNORM = 0.5*RZ IF (ZNORM .GT. 1.0) GO TO 30 IND = 0 CALL CKPS (Z, ZNORM, ZR, R1, U1, U2) GO TO 50 30 U1 = (1.0, 0.0) IF (X .LT. 0.0) GO TO 40 CALL CBKML (Z, ZNORM, ZR, R1, N, W1, U2) GO TO 50 40 IND = -1 CZ = - Z ZR = - ZR CALL CBKML (CZ, ZNORM, ZR, R1, N, W1, U2) C 50 IF (N .GT. 1) GO TO 70 W = U1 IF (N .NE. 0) W = U2 GO TO 90 C C RECURSION C 70 N1 = N - 1 DO 80 I = 1, N1 AI = I U3 = (R1 + AI)*ZR*U2 + U1 U1 = U2 U2 = U3 80 CONTINUE W = U3 C 90 IF (IND .EQ. 0) RETURN W = W*W1*CEXP(-CZ)/CSQRT(CZ) IF (IND .GT. 0) RETURN C C ANALYTIC CONTINUATION C C = EXP(0.5*B*PI) EX = CXP(M, NU) IF (Y .LT. 0.0) GO TO 100 EX = C*EX W1 = CMPLX (AIMAG(Z), -REAL(Z)) CALL CBSSLJ (W1, R, W2) W2 = CMPLX (PI*AIMAG(W2), -PI*REAL(W2)) W = EX*(EX*W + W2) RETURN 100 EX = CONJG(EX)/C W1 = CMPLX (-AIMAG(Z), REAL(Z)) CALL CBSSLJ (W1, R, W2) W2 = CMPLX (-PI*AIMAG(W2), PI*REAL(W2)) W = EX*(EX*W + W2) RETURN END SUBROUTINE CKPS (Z, R, ZR, NU, W1, W2) C----------------------------------------------------------------------- C C CALCULATION OF THE MODIFIED BESSEL FUNCTIONS C C W1 = K (Z) AND W2 = K (Z) C NU NU+1 C C FOR A COMPLEX ARGUMENT Z WHERE ABS(Z) .LE. 2 AND A COMPLEX C ORDER NU WHERE ABS(REAL(NU)) .LE. 0.5. IT IS ASSUMED THAT C -PI .LT. ARG Z .LE. PI, R = ABS(Z/2), AND ZR = 2/Z. POWER C SERIES EXPANSIONS ARE USED. C C----------------------------------------------------------------------- COMPLEX Z, ZR, NU, W1, W2 REAL D(7) COMPLEX A, C, CH, CL, F, G1, G2, GM1, GM2, MU, P, Q, SH, * T, T1, T2 COMPLEX CDIV, CGAM0 C----------------------- DATA TOL /1.E-10/ DATA PI /3.14159265358979/ C----------------------- DATA D(1) / .577215664901533E+00/, D(2) /-.420026350340952E-01/, * D(3) /-.421977345555443E-01/, D(4) / .721894324666310E-02/, * D(5) /-.215241674114951E-03/, D(6) /-.201348547807882E-04/, * D(7) / .113302723198170E-05/ C----------------------- ANORM(T) = AMAX1(ABS(REAL(T)), ABS(AIMAG(T))) C----------------------------------------------------------------------- C C ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE C SMALLEST NUMBER SUCH THAT 1 + EPS .GT. 1. C EPS = SPMPAR(1) C C----------------------------------------------------------------------- EPS0 = AMAX1(EPS, 5.E-15) C C CL = - LN(Z/2) C PHI = ATAN2(AIMAG(Z),REAL(Z)) CL = CMPLX(-ALOG(R), -PHI) MU = NU*CL C = CEXP(MU) C C G1 = GAMMA(1 + NU) C G2 = GAMMA(1 - NU) C T = PI*NU IF (ANORM(NU) .GT. TOL) GO TO 10 A = 1.0 + (T*T)/6.0 GO TO 20 10 A = T/CSIN(T) C 20 S = REAL(NU)**2 + AIMAG(NU)**2 IF (S .GE. 1.0) GO TO 21 T = CGAM0(NU) G1 = 1.0/T G2 = A*T GO TO 30 21 T = 0.5 + (0.5 + NU) CALL CGAMMA (0, T, G1) G2 = CDIV(A,G1) C 30 GM2 = 0.5*(G1 + G2) IF (S .GT. 0.04) GO TO 31 C C THE FOLLOWING IS THE TAYLOR SERIES FOR C W1 = (1/G2 - 1/G1)/(2*NU). NOTE THAT G1*G2 = A. C T = NU*NU W1 = -((((((D(7)*T + D(6))*T + D(5))*T + D(4))*T + * D(3))*T + D(2))*T + D(1)) GM1 = A*W1 GO TO 40 31 GM1 = 0.5*(G1 - G2)/NU C C INITIALIZATION OF THE SUMMATION C 40 P = 0.5*C*G1 Q = 0.5*CDIV(G2,C) X = REAL(MU) Y = AIMAG(MU) IF (ANORM(MU) .GT. TOL) GO TO 50 U = X*Y SH = CMPLX(1.0, U/3.0) CH = CMPLX(1.0, U) GO TO 60 50 T = CMPLX (-Y, X) SH = CSIN(T)/T CH = CCOS(T) C 60 F = GM1*CH + GM2*CL*SH C = (1.0, 0.0) W1 = F W2 = P C C SUMMATION OF SERIES C T = 0.25*(Z*Z) DO 70 K = 1, 50 AK = K F = (AK*F + P + Q)/((AK - NU)*(AK + NU)) P = P/(AK - NU) Q = Q/(AK + NU) C = C*T/AK T1 = C*F W1 = W1 + T1 T2 = C*(P - AK*F) W2 = W2 + T2 IF (ANORM(T1) .LE. EPS0*ANORM(W1)) GO TO 80 70 CONTINUE C 80 W2 = W2 * ZR RETURN END SUBROUTINE CBKML (Z, R, ZR, NU, N, W, W0) C----------------------------------------------------------------------- C C COMPUTATION OF THE SCALED BESSEL FUNCTION C C W = (EXP(Z)*SQRT(Z)) K (Z) C NU C AND THE VALUE C C W0 = K (Z) /K (Z) C NU+1 NU C C FOR COMPLEX ORDERS NU AND NU + 1 AND FOR COMPLEX ARGUMENT Z C BY USE OF THE MILLER ALGORITHM. FOR THE GREATEST ACCURACY, C Z SHOULD LIE IN A SECTOR SLIGHTLY LARGER THAN THE RIGHT HALF C PLANE. IT IS ASSUMED THAT ABS(REAL(NU)) .LT. 0.5, AND THAT C R = ABS(Z/2) AND ZR = 2/Z. C C----------------------------------------------------------------------- COMPLEX Z, ZR, NU, W, W0 COMPLEX AL, BL, S, U1, U2, U3 REAL INU, L C--------------------- C C1 = SQRT(PI/2) C C2 = SQRT(PI) C--------------------- DATA C1 /1.25331413731559E+00/ DATA C2 /1.77245385090552E+00/ C----------------------------------------------------------------------- C C ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE C SMALLEST NUMBER SUCH THAT 1 + EPS .GT. 1. C EPS = SPMPAR(1) C C----------------------------------------------------------------------- EPS0 = AMAX1(EPS, 5.E-15) C X = REAL(Z) Y = AIMAG(Z) RNU = REAL(NU) INU = AIMAG(NU) C C CALCULATION OF M FOR USE IN MILLER ALGORITHM. C TH = ATAN2(Y,X) A = 3.0/(1.0 + R) B = 14.7/(28.0 + R) F = (2.0*R)**(0.25) IF (RNU .EQ. 0.5 .AND. INU .NE. 0.0) GO TO 10 C = 4.0*COS1(RNU)/(C1*EPS0*F) GO TO 20 10 C = 4.0*C2/F 20 M = (0.485/R)*(ALOG(C) + R*COS(A*TH)/(1.0 + 0.008*R))**2/ * (2.0*COS(B*TH))**2 + 1.5 T = 0.0 IF (R .GT. 22.5) T = 0.01*(R - 22.5)**2 NUM = 35.0 + 0.8*(R - 22.5) + T IF (INU .NE. 0.0) M = M + NUM C = N IF (C + RNU .LT. 0.327*ABS(INU)) M = M + 10 C C BACKWARD RECURRENCE IN MILLER ALGORITHM. C A = (0.5 - RNU)*(0.5 + RNU) + INU*INU E = 2.0*RNU*INU U2 = (0.0, 0.0) U1 = (1.0, 0.0) S = U1 L = M DO 30 I = 2, M U3 = U2 U2 = U1 C = A/L + (L - 1.0) AL = CMPLX(C, - E/L) BL = 2.0*(L + Z) U1 = (BL*U2 - (L + 1.0)*U3)/AL S = S + U1 C = ABS(REAL(U1)) + ABS(AIMAG(U1)) IF (I .EQ. M .OR. C .LT. 1.E+8) GO TO 30 C C RESCALE TO AVOID OVERFLOW C U2 = U2/C U1 = U1/C S = S/C C 30 L = L - 1.0 C C LAST STEP IN THE MILLER ALGORITHM. C IF (C .LT. 2.0) GO TO 40 U2 = U2/C U1 = U1/C S = S/C 40 U3 = U2 U2 = U1 AL = CMPLX(0.5*A, - 0.5*E) BL = 1.0 + Z U1 = (BL*U2 - U3)/AL S = S + U1 C C FINAL ASSEMBLY C W = C1*(U1/S) W0 = 1.0 + 0.5*(NU + 0.5 - U2/U1)*ZR RETURN END SUBROUTINE CBSSLK (Z, R, W) C----------------------------------------------------------------------- C C CALCULATION OF THE MODIFIED BESSEL FUNCTION OF THE C SECOND KIND FOR REAL ORDER R AND COMPLEX ARGUMENT Z. C IT IS ASSUMED THAT -PI .LT. ARG Z .LE. PI. C C----------------------------------------------------------------------- C WRITTEN BY C ANDREW H. VAN TUYL C NAVAL SURFACE WARFARE CENTER C MODIFIED BY A.H. MORRIS (NSWC) C REVISED ... OCT 1992 C--------------------------- COMPLEX Z, W, CN, CZ, EX, U1, U2, U3, W1, W2, ZR REAL NU, NU1 COMPLEX CXP C--------------------------- C CPI = SQRT(PI/2) C--------------------------- DATA PI /3.14159265358979/ DATA CPI /1.25331413731550/ C RZ = CPABS(REAL(Z), AIMAG(Z)) C C ASYMPTOTIC EXPANSION C IF (RZ .LT. 17.5 + 0.5*R*R) GO TO 5 CALL CKA (Z, R, W) RETURN C C REDUCTION OF R TO THE RANGE -0.5 .LT. NU .LE. 0.5 C 5 A = ABS(R) N = A NU = A - FLOAT(N) T = NU - 0.5 IF (T .LE. 0.0) GO TO 10 NU = T - 0.5 N = N + 1 10 M = N NU1 = NU C IND = 1 CZ = Z X = 0.5*REAL(Z) Y = 0.5*AIMAG(Z) CALL CREC (X, Y, ZR1, ZR2) ZR = CMPLX (ZR1, ZR2) IF (T .NE. 0.0) GO TO 20 C C CALCULATION FOR NU = 0.5 C W = CMPLX(CPI, 0.0) IF (N .EQ. 0) GO TO 90 IF (X .GE. 0.0) GO TO 15 IND = -1 CZ = - Z ZR = - ZR 15 U1 = W U2 = W N = N + 1 NU = - 0.5 GO TO 70 C C CALCULATION FOR ABS(NU) .LT. 0.5 C 20 ZNORM = 0.5*RZ IF (ZNORM .GT. 1.0) GO TO 30 IND = 0 CALL CKM (Z, ZNORM, ZR, NU, U1, U2) GO TO 50 30 IF (X .LT. 0.0) GO TO 40 CALL CKML (Z, ZNORM, ZR, NU, U1, U2) GO TO 50 40 IND = -1 CZ = - Z ZR = - ZR CALL CKML (CZ, ZNORM, ZR, NU, U1, U2) C 50 IF (N .GT. 1) GO TO 70 W = U1 IF (N .NE. 0) W = U2 GO TO 90 C C RECURSION C 70 N1 = N - 1 DO 80 I = 1, N1 AI = I U3 = (NU + AI)*ZR*U2 + U1 U1 = U2 U2 = U3 80 CONTINUE W = U3 C 90 IF (IND .EQ. 0) RETURN W = W*CEXP(-CZ)/CSQRT(CZ) IF (IND .GT. 0) RETURN C C ANALYTIC CONTINUATION C EX = CXP(M, NU1) CN = CMPLX (A, 0.0) IF (Y .LT. 0.0) GO TO 100 W1 = CMPLX (AIMAG(Z), -REAL(Z)) CALL CBSSLJ (W1, CN, W2) W2 = CMPLX (PI*AIMAG(W2), -PI*REAL(W2)) W = EX*(EX*W + W2) RETURN 100 EX = CONJG(EX) W1 = CMPLX (-AIMAG(Z), REAL(Z)) CALL CBSSLJ (W1, CN, W2) W2 = CMPLX (-PI*AIMAG(W2), PI*REAL(W2)) W = EX*(EX*W + W2) RETURN END SUBROUTINE CKA (Z, NU, W) C----------------------------------------------------------------------- C COMPUTATION OF THE BESSEL FUNCTION K FOR REAL ORDER NU C AND COMPLEX ARGUMENT Z BY THE ASYMPTOTIC EXPANSION C----------------------------------------------------------------------- COMPLEX Z, W REAL M, NU COMPLEX P, T, ZR C-------------------------- ANORM(Z) = AMAX1(ABS(REAL(Z)), ABS(AIMAG(Z))) C-------------------------- C C = PI**(1/2) C-------------------------- DATA C /1.77245385090552/ C-------------------------- C C ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE C SMALLEST NUMBER SUCH THAT 1.0 + EPS .GT. 1.0 . C EPS = SPMPAR(1) C C-------------------------- CALL CREC (REAL(Z), AIMAG(Z), U, V) ZR = CMPLX(0.5*U, 0.5*V) A = NU*NU - 0.25 M = 1.0 T = A*ZR P = T C DO 10 I = 1, 16 A = A - 2.0*M M = M + 1.0 T = (A/M)*T*ZR P = P + T IF (ANORM(T) .LE. EPS*ANORM(P)) GO TO 20 10 CONTINUE C 20 P = P + 1.0 T = CSQRT(ZR) IF (AIMAG(Z) .EQ. 0.0) T = CONJG(T) W = C*T*P*CEXP(-Z) RETURN END SUBROUTINE CKM (Z, R, ZR, NU, W1, W2) C----------------------------------------------------------------------- C C CALCULATION OF THE MODIFIED BESSEL FUNCTIONS C C W1 = K (Z) AND W2 = K (Z) C NU NU+1 C C FOR A COMPLEX ARGUMENT Z WHERE ABS(Z) .LE. 2 AND A REAL C ORDER NU WHERE ABS(NU) .LE. 0.5. IT IS ASSUMED THAT C -PI .LT. ARG Z .LE. PI, R = ABS(Z/2), AND ZR = 2/Z. POWER C SERIES EXPANSIONS ARE USED. C C----------------------------------------------------------------------- COMPLEX Z, ZR, W1, W2 REAL NU, D(7) COMPLEX C, CH, CL, F, MU, P, Q, SH, T1, T2, W C----------------------- DATA TOL /1.E-10/ DATA PI /3.14159265358979/ C----------------------- DATA D(1) / .577215664901533E+00/, D(2) /-.420026350340952E-01/, * D(3) /-.421977345555443E-01/, D(4) / .721894324666310E-02/, * D(5) /-.215241674114951E-03/, D(6) /-.201348547807882E-04/, * D(7) / .113302723198170E-05/ C----------------------- ANORM(W) = AMAX1(ABS(REAL(W)), ABS(AIMAG(W))) C----------------------------------------------------------------------- C C ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE C SMALLEST NUMBER SUCH THAT 1 + EPS .GT. 1. C EPS = SPMPAR(1) C C----------------------------------------------------------------------- EPS0 = AMAX1(EPS, 5.E-15) C C CL = - LN(Z/2) C PHI = ATAN2(AIMAG(Z),REAL(Z)) CL = CMPLX(-ALOG(R), -PHI) MU = NU*CL C = CEXP(MU) C C G1 = GAMMA(1 + NU) C G2 = GAMMA(1 - NU) C T = PI*NU IF (ABS(NU) .GT. TOL) GO TO 10 A = 1.0 + (T*T)/6.0 GO TO 20 10 A = T/SIN(T) C 20 T = 0.5 + (0.5 + GAM1(NU)) G1 = 1.0/T G2 = A*T GM2 = 0.5*(G1 + G2) IF (ABS(NU) .GT. 0.2) GO TO 30 C C THE FOLLOWING IS THE TAYLOR SERIES FOR C T = (1/G2 - 1/G1)/(2*NU). NOTE THAT G1*G2 = A. C T = NU*NU T = -((((((D(7)*T + D(6))*T + D(5))*T + D(4))*T + * D(3))*T + D(2))*T + D(1)) GM1 = A*T GO TO 40 30 GM1 = 0.5*(G1 - G2)/NU C C INITIALIZATION OF THE SUMMATION C 40 P = (0.5*G1)*C Q = (0.5*G2)/C X = REAL(MU) Y = AIMAG(MU) IF (ANORM(MU) .GT. TOL) GO TO 50 T = X*Y SH = CMPLX(1.0, T/3.0) CH = CMPLX(1.0, T) GO TO 60 50 W = CMPLX (-Y, X) SH = CSIN(W)/W CH = CCOS(W) C 60 F = GM1*CH + GM2*CL*SH C = (1.0, 0.0) W1 = F W2 = P C C SUMMATION OF SERIES C W = 0.25*(Z*Z) DO 70 K = 1, 50 AK = K F = (AK*F + P + Q)/((AK - NU)*(AK + NU)) P = P/(AK - NU) Q = Q/(AK + NU) C = C*W/AK T1 = C*F W1 = W1 + T1 T2 = C*(P - AK*F) W2 = W2 + T2 IF (ANORM(T1) .LE. EPS0*ANORM(W1)) GO TO 80 70 CONTINUE C 80 W2 = W2 * ZR RETURN END SUBROUTINE CKML (Z, R, ZR, NU, K1, K2) C----------------------------------------------------------------------- C C COMPUTATION OF THE SCALED BESSEL FUNCTIONS C C K1 = (EXP(Z)*SQRT(Z)) K (Z) C NU C K2 = (EXP(Z)*SQRT(Z)) K (Z) C NU+1 C C FOR REAL ORDERS NU AND NU + 1 AND FOR COMPLEX ARGUMENT Z C BY USE OF THE MILLER ALGORITHM. FOR THE GREATEST ACCURACY, C Z SHOULD LIE IN A SECTOR SLIGHTLY LARGER THAN THE RIGHT C HALF PLANE. IT IS ASSUMED THAT ABS(NU) .LT. 0.5, AND THAT C R = ABS(Z/2) AND ZR = 2/Z. C C----------------------------------------------------------------------- COMPLEX Z, ZR, K1, K2 COMPLEX BL, S, U1, U2, U3 REAL L, NU, NU2 C--------------------- C C1 = SQRT(PI/2) C--------------------- DATA C1/1.25331413731559/ C----------------------------------------------------------------------- C C ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE C SMALLEST NUMBER SUCH THAT 1 + EPS .GT. 1. C EPS = SPMPAR(1) C C----------------------------------------------------------------------- EPS0 = AMAX1(EPS, 5.E-15) X = REAL(Z) Y = AIMAG(Z) NU2 = NU*NU C C CALCULATION OF M FOR USE IN MILLER ALGORITHM. C TH = ATAN2(Y,X) A = 3.0/(1.0 + R) B = 14.7/(28.0 + R) C = 4.0*COS1(NU)/(C1*EPS0*(2.0*R)**(0.25)) M = (0.485/R)*(ALOG(C) + R*COS(A*TH)/(1.0 + 0.008*R))**2/ * (2.0*COS(B*TH))**2 + 1.5 C C BACKWARD RECURRENCE IN MILLER ALGORITHM. C U2 = (0.0, 0.0) U1 = (1.0, 0.0) S = U1 L = M DO 10 I = 2, M U3 = U2 U2 = U1 E = L - 0.5 AL = (E*E - NU2)/(L*(L + 1.0)) BL = (2.0/(L + 1.0))*(L + Z) U1 = (BL*U2 - U3)/AL S = S + U1 C = ABS(REAL(U1)) + ABS(AIMAG(U1)) IF (I .EQ. M .OR. C .LT. 1.E+6) GO TO 10 C C RESCALE TO AVOID OVERFLOW C U2 = U2/C U1 = U1/C S = S/C C 10 L = L - 1.0 C C LAST STEP IN THE MILLER ALGORITHM. C IF (C .LT. 2.0) GO TO 20 U2 = U2/C U1 = U1/C S = S/C 20 U3 = U2 U2 = U1 AL = 0.5*(0.5 - NU)*(0.5 + NU) BL = 1.0 + Z U1 = (BL*U2 - U3)/AL S = S + U1 C C FINAL ASSEMBLY C K1 = C1*(U1/S) K2 = K1*(1.0 + 0.5*(NU + 0.5 - U2/U1)*ZR) RETURN END COMPLEX FUNCTION CXP (N, NU) C----------------------------------------------------------------------- C COMPUTATION OF EXP(-R*(PI/2)*I) C WHERE R = N + NU FOR ABS(NU) .LE. 0.5 C----------------------------------------------------------------------- REAL NU C C = COS0(NU) S = SIN0(NU) K = MOD(N,4) IF (K .EQ. 0) GO TO 10 IF (K .EQ. 1) GO TO 20 IF (K .EQ. 2) GO TO 30 GO TO 40 C 10 CXP = CMPLX (C, -S) RETURN C 20 CXP = CMPLX (-S, -C) RETURN C 30 CXP = CMPLX (-C, S) RETURN C 40 CXP = CMPLX (S, C) RETURN END SUBROUTINE BSSLK (MO, A, IN, W) C ****************************************************************** C FORTRAN SUBROUTINE FOR MODIFIED BESSEL FUNCTION OF INTEGRAL ORDER C ****************************************************************** C MO = MODE OF OPERATION C A = ARGUMENT (COMPLEX NUMBER) C IN = ORDER (INTEGER) C W = FUNCTION OF SECOND KIND (COMPLEX NUMBER) C ------------------- COMPLEX A, W DIMENSION AZ(2) DIMENSION CD(30), CE(30) DIMENSION SZ(2), RZ(2), ZL(2) DIMENSION TS(2), TM(2), SM(2), SL(2), SQ(2), SR(2), AQ(2), QF(2) DATA CD(1) / 0.00000000000000E00/, CD(2) /-1.64899505142212E-2/, 1 CD(3) /-7.18621880068536E-2/, CD(4) /-1.67086878124866E-1/, 2 CD(5) /-3.02582250219469E-1/, CD(6) /-4.80613945245927E-1/, 3 CD(7) /-7.07075239357898E-1/, CD(8) /-9.92995790539516E-1/, 4 CD(9) /-1.35583925612592E00/, CD(10)/-1.82105907899132E00/, 5 CD(11)/-2.42482175310879E00/, CD(12)/-3.21956655708750E00/, 6 CD(13)/-4.28658077248384E00/, CD(14)/-5.77022816798128E00/, 7 CD(15)/-8.01371260952526E00/ DATA CD(16)/ 0.00000000000000E00/, CD(17)/-5.57742429879505E-3/, 1 CD(18)/-4.99112944172476E-2/, CD(19)/-1.37440911652397E-1/, 2 CD(20)/-2.67233784710566E-1/, CD(21)/-4.40380166808682E-1/, 3 CD(22)/-6.61813614872541E-1/, CD(23)/-9.41861077665017E-1/, 4 CD(24)/-1.29754130468326E00/, CD(25)/-1.75407696719816E00/, 5 CD(26)/-2.34755299882276E00/, CD(27)/-3.13041332689196E00/, 6 CD(28)/-4.18397120563729E00/, CD(29)/-5.65251799214994E00/, 7 CD(30)/-7.87863959810677E00/ DATA CE(1) / 0.00000000000000E00/, CE(2) /-4.80942336387447E-3/, 1 CE(3) /-1.31366200347759E-2/, CE(4) /-1.94843834008458E-2/, 2 CE(5) /-2.19948900032003E-2/, CE(6) /-2.09396625676519E-2/, 3 CE(7) /-1.74600268458650E-2/, CE(8) /-1.27937813362085E-2/, 4 CE(9) /-8.05234421796592E-3/, CE(10)/-4.15817375002760E-3/, 5 CE(11)/-1.64317738747922E-3/, CE(12)/-4.49175585314709E-4/, 6 CE(13)/-7.28594765574007E-5/, CE(14)/-5.38265230658285E-6/, 7 CE(15)/-9.93779048036289E-8/ DATA CE(16)/ 0.00000000000000E00/, CE(17)/ 7.53805779200591E-2/, 1 CE(18)/ 7.12293537403464E-2/, CE(19)/ 6.33116224228200E-2/, 2 CE(20)/ 5.28240264523301E-2/, CE(21)/ 4.13305359441492E-2/, 3 CE(22)/ 3.01350573947510E-2/, CE(23)/ 2.01043439592720E-2/, 4 CE(24)/ 1.18552223068074E-2/, CE(25)/ 5.86055510956010E-3/, 5 CE(26)/ 2.25465148267325E-3/, CE(27)/ 6.08173041536336E-4/, 6 CE(28)/ 9.84215550625747E-5/, CE(29)/ 7.32139093038089E-6/, 7 CE(30)/ 1.37279667384666E-7/ C ------------------- AZ(1)=REAL(A) AZ(2)=AIMAG(A) ZS=AZ(1)*AZ(1)+AZ(2)*AZ(2) ZL(1)=0.5*ALOG(ZS) ZL(2)=ATAN2(AZ(2),AZ(1)) AN=IABS(IN) TM(1)=0.0 TM(2)=0.0 IF(MO.NE.0)GO TO 002 TM(1)=AZ(1) TM(2)=AZ(2) 002 IF(ZS-1.0)020,020,003 003 IF(ZS-289.0)004,010,010 004 IF(AZ(1)+0.096*AZ(2)*AZ(2))020,020,015 010 QM=1.25331413731550*EXP(-0.5*ZL(1)-TM(1)) QF(1)=QM*COS(-0.5*ZL(2)-TM(2)) QF(2)=QM*SIN(-0.5*ZL(2)-TM(2)) IF(AN.GT.1.0)GO TO 012 PN=AN ASSIGN 011 TO LA GO TO 100 011 TS(1)=QF(1)*SM(1)-QF(2)*SM(2) TS(2)=QF(1)*SM(2)+QF(2)*SM(1) SM(1)=TS(1) SM(2)=TS(2) GO TO 029 012 PN=1.0 ASSIGN 013 TO LA GO TO 100 013 SQ(1)=QF(1)*SM(1)-QF(2)*SM(2) SQ(2)=QF(1)*SM(2)+QF(2)*SM(1) PN=0.0 ASSIGN 014 TO LA GO TO 100 014 SR(1)=QF(1)*SM(1)-QF(2)*SM(2) SR(2)=QF(1)*SM(2)+QF(2)*SM(1) GO TO 026 015 QM=1.25331413731550*EXP(-0.5*ZL(1)-TM(1)) QF(1)=QM*COS(-0.5*ZL(2)-TM(2)) QF(2)=QM*SIN(-0.5*ZL(2)-TM(2)) IF(AN.GT.1.0)GO TO 017 PN=AN ASSIGN 016 TO LR GO TO 104 016 TS(1)=QF(1)*SM(1)-QF(2)*SM(2) TS(2)=QF(1)*SM(2)+QF(2)*SM(1) SM(1)=TS(1) SM(2)=TS(2) GO TO 029 017 PN=1.0 ASSIGN 018 TO LR GO TO 104 018 SQ(1)=QF(1)*SM(1)-QF(2)*SM(2) SQ(2)=QF(1)*SM(2)+QF(2)*SM(1) PN=0.0 ASSIGN 019 TO LR GO TO 104 019 SR(1)=QF(1)*SM(1)-QF(2)*SM(2) SR(2)=QF(1)*SM(2)+QF(2)*SM(1) GO TO 026 020 QF(1)=1.0 QF(2)=0.0 IF(MO.EQ.0)GO TO 021 QM=EXP(AZ(1)) QF(1)=QM*COS(AZ(2)) QF(2)=QM*SIN(AZ(2)) 021 IF(AN.GT.1.0)GO TO 023 PN=AN ASSIGN 022 TO LK GO TO 106 022 TS(1)=QF(1)*SM(1)-QF(2)*SM(2) TS(2)=QF(1)*SM(2)+QF(2)*SM(1) SM(1)=TS(1) SM(2)=TS(2) GO TO 029 023 PN=1.0 ASSIGN 024 TO LK GO TO 106 024 SQ(1)=QF(1)*SM(1)-QF(2)*SM(2) SQ(2)=QF(1)*SM(2)+QF(2)*SM(1) PN=0.0 ASSIGN 025 TO LK GO TO 106 025 SR(1)=QF(1)*SM(1)-QF(2)*SM(2) SR(2)=QF(1)*SM(2)+QF(2)*SM(1) 026 RZ(1)=+AZ(1)/ZS RZ(2)=-AZ(2)/ZS PN=0.0 GO TO 028 027 SQ(1)=SR(1) SQ(2)=SR(2) SR(1)=SM(1) SR(2)=SM(2) 028 SM(1)=2.0*PN*(RZ(1)*SR(1)-RZ(2)*SR(2))+SQ(1) SM(2)=2.0*PN*(RZ(1)*SR(2)+RZ(2)*SR(1))+SQ(2) PN=PN+1.0 IF(PN.LT.AN)GO TO 027 029 W=CMPLX(SM(1),SM(2)) RETURN 100 SM(1)=0.0 SM(2)=0.0 RZ(1)=+0.5*AZ(1)/ZS RZ(2)=-0.5*AZ(2)/ZS QN=(PN-0.5)*(PN+0.5) TM(1)=1.0 TM(2)=0.0 PM=0.0 GO TO 102 101 QN=QN-2.0*PM PM=PM+1.0 TS(1)=RZ(1)*TM(1)-RZ(2)*TM(2) TS(2)=RZ(1)*TM(2)+RZ(2)*TM(1) TM(1)=QN*TS(1)/PM TM(2)=QN*TS(2)/PM IF(ABS(SM(1))+ABS(TM(1)).NE.ABS(SM(1)))GO TO 102 IF(ABS(SM(2))+ABS(TM(2)).EQ.ABS(SM(2)))GO TO 103 102 SM(1)=SM(1)+TM(1) SM(2)=SM(2)+TM(2) IF(PM.LT.36.0)GO TO 101 103 GO TO LA,(011,013,014) 104 SM(1)=1.0 SM(2)=0.0 M=15.0*PN+2.0 N=15.0*PN+15.0 DO 105 I=M,N TS(1)=AZ(1)-CD(I) TS(2)=AZ(2) SS=TS(1)*TS(1)+TS(2)*TS(2) TM(1)=+CE(I)*TS(1)/SS TM(2)=-CE(I)*TS(2)/SS SM(1)=SM(1)+TM(1) SM(2)=SM(2)+TM(2) 105 CONTINUE GO TO LR,(016,018,019) 106 AQ(1)=1.0 AQ(2)=0.0 RN=0.0 SN=-1.0 PM=0.0 GO TO 108 107 PM=PM+1.0 RN=RN+0.5/PM SN=-SN TS(1)=0.5*(AZ(1)*AQ(1)-AZ(2)*AQ(2)) TS(2)=0.5*(AZ(1)*AQ(2)+AZ(2)*AQ(1)) AQ(1)=TS(1)/PM AQ(2)=TS(2)/PM 108 IF(PM.LT.PN)GO TO 107 SZ(1)=0.25*(AZ(1)-AZ(2))*(AZ(1)+AZ(2)) SZ(2)=0.5*AZ(1)*AZ(2) SR(1)=0.0 SR(2)=0.0 SS=AQ(1)*AQ(1)+AQ(2)*AQ(2) TM(1)=+AQ(1)/SS TM(2)=-AQ(2)/SS PM=0.0 GO TO 110 109 TM(1)=TM(1)/(PN-PM) TM(2)=TM(2)/(PN-PM) SR(1)=SR(1)+0.5*TM(1) SR(2)=SR(2)+0.5*TM(2) PM=PM+1.0 TS(1)=SZ(1)*TM(1)-SZ(2)*TM(2) TS(2)=SZ(1)*TM(2)+SZ(2)*TM(1) TM(1)=-TS(1)/PM TM(2)=-TS(2)/PM 110 IF(PM.LT.PN)GO TO 109 SM(1)=0.0 SM(2)=0.0 RM=1.0 QM=0.0 AQ(1)=SN*AQ(1) AQ(2)=SN*AQ(2) SL(1)=-0.115931515658412+ZL(1)-RN SL(2)=+ZL(2) PM=0.0 GO TO 112 111 QM=QM+RM PM=PM+1.0 RM=0.25*ZS*RM/(PM*(PN+PM)) TS(1)=SZ(1)*AQ(1)-SZ(2)*AQ(2) TS(2)=SZ(1)*AQ(2)+SZ(2)*AQ(1) AQ(1)=TS(1)/(PM*(PN+PM)) AQ(2)=TS(2)/(PM*(PN+PM)) SL(1)=SL(1)-0.5/PM-0.5/(PN+PM) 112 TM(1)=AQ(1)*SL(1)-AQ(2)*SL(2) TM(2)=AQ(1)*SL(2)+AQ(2)*SL(1) SM(1)=SM(1)+TM(1) SM(2)=SM(2)+TM(2) IF(QM+RM.GT.QM)GO TO 111 SM(1)=SR(1)+SM(1) SM(2)=SR(2)+SM(2) GO TO LK,(022,024,025) END SUBROUTINE CAI(IND,Z,AI,AIP,IERR) C------------------------------------------------------------ C CALCULATES THE AIRY FUNCTION AI AND ITS DERIVATIVE AIP C FOR COMPLEX ARGUMENT Z. C------------------------------------------------------------ COMPLEX Z,AI,BI,AIP,BIP IERR = 0 A = REAL(Z) B = AIMAG(Z) R = CPABS(A,B) IF(R .GT. 1.0) GO TO 10 C C MACLAURIN EXPANSION C CALL AIRM(IND,Z,AI,AIP,BI,BIP) RETURN 10 IF(R .GT. 10.0) GO TO 20 C C INTERMEDIATE RANGE CALCULATION C CALL AII(IND,Z,AI,AIP,IERR) RETURN C C ASYMPTOTIC EXPANSION C 20 CALL AIA(IND,Z,AI,AIP,IERR) RETURN END SUBROUTINE AIRM (IND,Z,AI,AIP,BI,BIP) C-------------------------------------------------------------- C CALCULATES THE AIRY FUNCTIONS AI AND BI AND THEIR C DERIVATIVES AIP AND BIP BY USE OF THEIR MACLAURIN C EXPANSIONS. C-------------------------------------------------------------- COMPLEX AI, AIP, BI, BIP, Z, Z1, Z2, Z3, ZZ, F, F1, G, G1, * E, E1 REAL A(8), B(8), C(8), D(8) C----------------------- C C1 = 3**(-2/3)/GAMMA(2/3) C C2 = 3**(-1/3)/GAMMA(1/3) C----------------------- DATA C1/3.55028053887817E-01/, C2/2.58819403792807E-01/, 1 SQT3/1.73205080756888E+00/ C----------------------- DATA A(1) /.166666666666667E+00/, A(2) /.555555555555556E-02/, * A(3) /.771604938271605E-04/, A(4) /.584549195660307E-06/, * A(5) /.278356759838241E-08/, A(6) /.909662613850462E-11/, * A(7) /.216586336631062E-13/, A(8) /.392366551867867E-16/ DATA B(1) /.833333333333333E-01/, B(2) /.198412698412698E-02/, * B(3) /.220458553791887E-04/, B(4) /.141319585764030E-06/, * B(5) /.588831607350126E-09/, B(6) /.172172984605300E-11/, * B(7) /.372668797846970E-14/, B(8) /.621114663078283E-17/ DATA C(1) /.333333333333333E-01/, C(2) /.694444444444444E-03/, * C(3) /.701459034792368E-05/, C(4) /.417535139757362E-07/, * C(5) /.163739270493083E-09/, C(6) /.454831306925231E-12/, * C(7) /.941679724482880E-15/, C(8) /.150910212256872E-17/ DATA D(1) /.333333333333333E+00/, D(2) /.138888888888889E-01/, * D(3) /.220458553791887E-03/, D(4) /.183715461493239E-05/, * D(5) /.942130571760201E-08/, D(6) /.327128670750070E-10/, * D(7) /.819871355263333E-13/, D(8) /.155278665769571E-15/ C----------------------- Z2 = Z*Z Z3 = Z*Z2 C C SUMMATION OF F AND G C F = CMPLX(A(8),0.0) G = CMPLX(B(8),0.0) DO 10 N = 1, 7 I = 8 - N F = A(I) + Z3*F G = B(I) + Z3*G 10 CONTINUE F = 1.0 + Z3*F G = Z + Z2*Z2*G C C SUMMATION OF F1 AND G1 C F1 = CMPLX(C(8),0.0) G1 = CMPLX(D(8),0.0) DO 20 N = 1,7 I = 8 - N F1 = C(I) + Z3*F1 G1 = D(I) + Z3*G1 20 CONTINUE F1 = Z2*(0.5 + Z3*F1) G1 = 1.0 + Z3*G1 C C FINAL ASSEMBLY C AI = C1*F - C2*G BI = SQT3*(C1*F + C2*G) AIP = C1*F1 - C2*G1 BIP = SQT3*(C1*F1 + C2*G1) IF (IND .EQ. 0) RETURN X = REAL(Z) Y = AIMAG(Z) Z1 = CSQRT(Z) ZZ = Z*Z1/1.5 E = CEXP(ZZ) E1 = 1.0/E AI = AI*E AIP = AIP*E IF (ABS(Y) .GT. X*SQT3) GO TO 30 BI = BI*E1 BIP = BIP*E1 RETURN 30 BI = BI*E BIP = BIP*E RETURN END SUBROUTINE AII(IND, Z, AI, AIP, IERR) C------------------------------------------------------------ C CALCULATES THE AIRY FUNCTION AI AND ITS DERIVATIVE AIP C FOR COMPLEX ARGUMENT Z IN THE INTERMEDIATE RANGE 1 .LE. C CABS(Z) .LE. 10.0. C------------------------------------------------------------ COMPLEX Z, AI, AIP, Z1, Z2, Z3, ZM, W1, W2, W1M, W2M, E C C C1 = 1/(PI*SQRT(3)) C DATA C1/1.83776298473931E-01/ IERR = 0 A = REAL(Z) B = AIMAG(Z) R = CPABS(A, B) Z1 = CSQRT(Z) Z2 = Z1*Z/1.5 IF (ABS(B) .LT. -5.0*A) GO TO 10 C C ---- ABS(B) .GE. -5.0*A ---- C CALL KA(IND, Z2, W1, W2) AI = C1*Z1*W1 AIP = -C1*Z*W2 RETURN C C ---- ABS(B) .LT. -5.0*A ---- C 10 IF (ABS(B) .LT. -1.74*A) GO TO 30 IF (R .GE. 8.2) GO TO 40 20 ZM = -Z Z1 = CSQRT(ZM) Z3 = Z1*ZM/1.5 CALL JA(Z3, W1, W2, W1M, W2M) AI = (Z1/3.0)*(W1M +W1) AIP = (Z/3.0)*(W2M - W2) IF (IND .EQ. 0) RETURN E = CEXP(Z2) AI = AI*E AIP = AIP*E RETURN 30 IF (R .LT. 7.4) GO TO 20 40 CALL AIA (IND,Z,AI,AIP,IERR) RETURN END SUBROUTINE AIA (IND, Z, AI, AIP, IERR) C----------------------------------------------------------------------- C CALCULATES THE AIRY FUNCTION AI AND ITS DERIVATIVE AIP FOR C COMPLEX ARGUMENT Z BY MEANS OF ASYMPTOTIC EXPANSIONS. C----------------------------------------------------------------------- COMPLEX AI,AIP,Z,Z1,Z2,Z2R,ZZ,W,W2,S1,S2,S3,S4,E,ZETA,SI,CN COMPLEX ALPHA,BETA,J REAL C(30), D(30) C------------------------ DATA C(1) /.100000000000000E+01/, C(2) /.694444444444444E-01/, * C(3) /.371334876543210E-01/, C(4) /.379930591278006E-01/, * C(5) /.576491904126697E-01/, C(6) /.116099064025515E+00/, * C(7) /.291591399230751E+00/, C(8) /.877666969510017E+00/, * C(9) /.307945303017317E+01/, C(10) /.123415733323452E+02/, * C(11) /.556227853659171E+02/, C(12) /.278465080777603E+03/, * C(13) /.153316943201280E+04/, C(14) /.920720659972641E+04/, * C(15) /.598925135658791E+05/, C(16) /.419524875116551E+06/, * C(17) /.314825741786683E+07/, C(18) /.251989198716024E+08/, * C(19) /.214288036963680E+09/, C(20) /.192937554918249E+10/ DATA C(21) /.183357669378906E+11/, C(22) /.183418303528833E+12/, * C(23) /.192647115897045E+13/, C(24) /.211969993886476E+14/, * C(25) /.243826826879716E+15/, C(26) /.292659921929793E+16/, * C(27) /.365903070126431E+17/, C(28) /.475768102036307E+18/, * C(29) /.642404935790194E+19/, C(30) /.899520742705838E+20/ C------------------------ DATA D(1) / .100000000000000E+01/, D(2) /-.972222222222222E-01/, * D(3) /-.438850308641975E-01/, D(4) /-.424628307898948E-01/, * D(5) /-.626621634920323E-01/, D(6) /-.124105896027275E+00/, * D(7) /-.308253764901079E+00/, D(8) /-.920479992412945E+00/, * D(9) /-.321049358464862E+01/, D(10) /-.128072930807356E+02/, * D(11) /-.575083035139143E+02/, D(12) /-.287033237109221E+03/, * D(13) /-.157635730333710E+04/, D(14) /-.944635482309593E+04/, * D(15) /-.613357066638521E+05/, D(16) /-.428952400400069E+06/, * D(17) /-.321453652140086E+07/, D(18) /-.256979083839113E+08/, * D(19) /-.218293420832160E+09/, D(20) /-.196352378899103E+10/ DATA D(21) /-.186439310881072E+11/, D(22) /-.186352996385294E+12/, * D(23) /-.195588293238984E+13/, D(24) /-.215064446351972E+14/, * D(25) /-.247236992290621E+15/, D(26) /-.296588243029521E+16/, * D(27) /-.370624400063547E+17/, D(28) /-.481678264794522E+18/, * D(29) /-.650098408075106E+19/, D(30) /-.909919826436541E+20/ C------------------------ C C1 = PI**(-1/2) C C2 = (2*PI)**(-1/2) C------------------------ DATA C1 /.564189583547756/ DATA C2 /.398942280401433/ C------------------------ C C EPS, XPOS, AND XNEG ARE MACHINE DEPENDENT CONSTANTS. EPS IS C THE SMALLEST NUMBER SUCH THAT 1.0 + EPS .GT. 1.0, XPOS IS THE C THE LARGEST POSTIVE NUMBER FOR WHICH EXP(X) CAN BE COMPUTED, C AND XNEG IS THE LARGEST NEGATIVE NUMBER FOR WHICH EXP(X) DOES C NOT UNDERFLOW. C EPS = SPMPAR(1) XPOS = EXPARG(0) XNEG = EXPARG(1) C C------------------------ IERR = 0 IF (REAL(Z) .LT. 0.0) GO TO 30 C C ----- REAL(Z) .GE. 0 ----- C Z1 = CSQRT(Z) Z2 = CSQRT(Z1) Z2R = 1.0/Z2 CALL CREC (REAL(Z), AIMAG(Z), U, V) W = -1.5*CMPLX(U,V)/Z1 U = ABS(REAL(W)) V = ABS(AIMAG(W)) T = AMAX1(U,V) IF (IND .NE. 0) GO TO 10 C IF (T .EQ. 0.0) GO TO 90 U1 = U/T V1 = V/T R = U*U1 + V*V1 XM = XPOS IF (REAL(W) .LT. 0.0) XM = -XNEG IF (U1 .GE. R*XM .OR. V1 .GE. 0.1*R/EPS) GO TO 90 ZETA = Z1*Z/1.5 E = CEXP(-ZETA) C 10 M = 20 IF (T .GT. 30.0) M = 8 S1 = CMPLX(C(M),0.0) S2 = CMPLX(D(M),0.0) I = M DO 20 K = 2,M I = I - 1 S1 = C(I) + W*S1 S2 = D(I) + W*S2 20 CONTINUE C AI = 0.5*C1*Z2R*S1 AIP = - 0.5*C1*Z2*S2 IF (IND .NE. 0) RETURN AI = E*AI AIP = E*AIP RETURN C C ----- REAL(Z) .LT. 0 ----- C 30 ZZ = -Z Z1 = CSQRT(ZZ) Z2 = CSQRT(Z1) Z2R = 1.0/Z2 CALL CREC (REAL(ZZ), AIMAG(ZZ), U, V) W = 1.5*CMPLX(U,V)/Z1 U = ABS(REAL(W)) V = ABS(AIMAG(W)) T = AMAX1(U,V) C IF (T .EQ. 0.0) GO TO 90 U1 = U/T V1 = V/T R = U*U1 + V*V1 IF (IND .NE. 0) GO TO 40 IF (V1 .GE. R*XPOS .OR. U1 .GE. 0.1*R/EPS) GO TO 90 ZETA = Z1*ZZ/1.5 GO TO 50 40 E = (0.0, 0.0) J = (0.0, -1.0) IF (AIMAG(Z) .LT. 0.0) J = (0.0, 1.0) IF (V1 .GT. 0.5*R*ABS(XNEG)) GO TO 50 IF (U1 .GE. 0.05*R/EPS) GO TO 90 ZETA = Z1*ZZ/1.5 E = CEXP(2.0*J*ZETA) C 50 W2 = W*W M = 15 IF (T .GT. 30.0) M = 5 M2 = M + M I = M2 - 1 S1 = CMPLX(C(I),0.0) S2 = CMPLX(C(M2),0.0) S3 = CMPLX(D(I),0.0) S4 = CMPLX(D(M2),0.0) DO 60 K = 2,M I = I - 1 S2 = C(I) - S2*W2 S4 = D(I) - S4*W2 I = I - 1 S1 = C(I) - S1*W2 S3 = D(I) - S3*W2 60 CONTINUE S2 = W*S2 S4 = W*S4 C IF (IND .NE. 0) GO TO 70 CN = CCOS(ZETA) SI = CSIN(ZETA) GO TO 80 70 CN = 0.5*(1.0 + E) SI = 0.5*(1.0 - E)*J C 80 ALPHA = S1 - S2 BETA = S1 + S2 AI = C2*Z2R*(ALPHA*CN + BETA*SI) ALPHA = S3 - S4 BETA = S3 + S4 AIP = C2*Z2*(ALPHA*SI - BETA*CN) RETURN C C RETURN WITH ZERO VALUES IF SCALING IS NEEDED C 90 AI = (0.0, 0.0) AIP = (0.0, 0.0) IERR = 1 RETURN END SUBROUTINE CBI(IND,Z,BI,BIP,IERR) C------------------------------------------------------------ C CALCULATES THE AIRY FUNCTION BI AND ITS DERIVATIVE BIP C FOR COMPLEX ARGUMENT Z. C------------------------------------------------------------ COMPLEX Z,AI,BI,AIP,BIP IERR = 0 A = REAL(Z) B = AIMAG(Z) R = CPABS(A,B) IF(R .GT. 1.0) GO TO 10 C C MACLAURIN EXPANSION C CALL AIRM(IND,Z,AI,AIP,BI,BIP) RETURN 10 IF(R .GT. 9.6) GO TO 20 C C INTERMEDIATE RANGE CALCULATION C CALL BII(IND,Z,BI,BIP,IERR) RETURN C C ASYMPTOTIC EXPANSION C 20 CALL BIA(IND,Z,BI,BIP,IERR) RETURN END SUBROUTINE BII(IND, Z, BI, BIP, IERR) C------------------------------------------------------------ C CALCULATES THE AIRY FUNCTION BI AND ITS DERIVATIVE BIP C FOR COMPLEX ARGUMENT Z IN THE INTERMEDIATE RANGE 1 .LE. C CABS(Z) .LE. 10.0. C------------------------------------------------------------ COMPLEX Z, BI, BIP, Z1, Z2, ZM, W1, W2, W1M, W2M, E, E1 C C C1 = 1/SQRT(3) C SQT3 = SQRT(3) C DATA C1/5.77350269189626E-01/ DATA SQT3/1.73205080756888E+00/ C IERR = 0 X = REAL(Z) Y = AIMAG(Z) R = CPABS(X, Y) Z1 = CSQRT(Z) Z2 = Z1*Z/1.5 E = CEXP(-Z2) E1 = 1.0/E IF(REAL(Z) .LT. 0.0) GO TO 10 C C ---- REAL(Z) .GE. 0 ---- C IF (R .LT. 8.9) GO TO 5 A = 0.156*R - 0.913 IF (ABS(Y) .LT. A*X .OR. ABS(Y) .GT. 0.58*X) GO TO 40 5 CALL IA(Z2, W1, W2, W1M, W2M) BI = C1*Z1*(W1 + W1M) BIP = C1*Z*(W2 + W2M) IF (IND .EQ. 0) RETURN GO TO 20 C C ---- REAL(Z) .LT. 0 ---- C 10 IF (R .LT. 8.1) GO TO 15 IF (ABS(Y) .LT. 3.89*ABS(X)) GO TO 40 15 ZM = -Z Z1 = CSQRT(ZM) Z2 = Z1*ZM/1.5 CALL JA(Z2, W1, W2, W1M, W2M) BI = C1*Z1*(W1M -W1) BIP = C1*ZM*(W2M + W2) IF (IND .EQ. 0) RETURN 20 IF (X .GE. C1*ABS(Y)) GO TO 30 BI = BI*E1 BIP = BIP*E1 RETURN 30 BI = BI*E BIP = BIP*E RETURN 40 CALL BIA(IND, Z, BI, BIP, IERR) RETURN END SUBROUTINE BIA(IND,Z,BI,BIP,IERR) C--------------------------------------------------------------- C CALCULATES THE AIRY FUNCTION BI AND ITS DERIVATIVE BIP FOR C COMPLEX ARGUMENT Z BY MEANS OF ASYMPTOTIC EXPANSIONS. C--------------------------------------------------------------- COMPLEX Z,BI,BIP,Z1,Z2,Z2R,ZZ,W,W2,S1,S2,S3,S4,E,ZETA,SI,CN, * CF1,CF2,EX3C,EX6,EX6C,CLN2,ALPHA,BETA,J,CZ DIMENSION C(30), D(30) C------------------------ DATA C(1) /.100000000000000E+01/, C(2) /.694444444444444E-01/, * C(3) /.371334876543210E-01/, C(4) /.379930591278006E-01/, * C(5) /.576491904126697E-01/, C(6) /.116099064025515E+00/, * C(7) /.291591399230751E+00/, C(8) /.877666969510017E+00/, * C(9) /.307945303017317E+01/, C(10) /.123415733323452E+02/, * C(11) /.556227853659171E+02/, C(12) /.278465080777603E+03/, * C(13) /.153316943201280E+04/, C(14) /.920720659972641E+04/, * C(15) /.598925135658791E+05/, C(16) /.419524875116551E+06/, * C(17) /.314825741786683E+07/, C(18) /.251989198716024E+08/, * C(19) /.214288036963680E+09/, C(20) /.192937554918249E+10/ DATA C(21) /.183357669378906E+11/, C(22) /.183418303528833E+12/, * C(23) /.192647115897045E+13/, C(24) /.211969993886476E+14/, * C(25) /.243826826879716E+15/, C(26) /.292659921929793E+16/, * C(27) /.365903070126431E+17/, C(28) /.475768102036307E+18/, * C(29) /.642404935790194E+19/, C(30) /.899520742705838E+20/ C------------------------ DATA D(1) / .100000000000000E+01/, D(2) /-.972222222222222E-01/, * D(3) /-.438850308641975E-01/, D(4) /-.424628307898948E-01/, * D(5) /-.626621634920323E-01/, D(6) /-.124105896027275E+00/, * D(7) /-.308253764901079E+00/, D(8) /-.920479992412945E+00/, * D(9) /-.321049358464862E+01/, D(10) /-.128072930807356E+02/, * D(11) /-.575083035139143E+02/, D(12) /-.287033237109221E+03/, * D(13) /-.157635730333710E+04/, D(14) /-.944635482309593E+04/, * D(15) /-.613357066638521E+05/, D(16) /-.428952400400069E+06/, * D(17) /-.321453652140086E+07/, D(18) /-.256979083839113E+08/, * D(19) /-.218293420832160E+09/, D(20) /-.196352378899103E+10/ DATA D(21) /-.186439310881072E+11/, D(22) /-.186352996385294E+12/, * D(23) /-.195588293238984E+13/, D(24) /-.215064446351972E+14/, * D(25) /-.247236992290621E+15/, D(26) /-.296588243029521E+16/, * D(27) /-.370624400063547E+17/, D(28) /-.481678264794522E+18/, * D(29) /-.650098408075106E+19/, D(30) /-.909919826436541E+20/ C------------------------- C SQT3 = SQRT(3) C EX3C = EXP(-I*PI/3) C EX6 = EXP(I*PI/6) C EX6C = EXP(-I*PI/6) C CLN2 = 0.5*I*LN(2) C C1 = PI**(-1/2) C C2 = (2*PI)**(-1/2) C C3 = 2**(-1/2) C-------------------------- DATA SQT3/1.73205080756888/ DATA EX3C/(5.E-01, -8.66025403784439E-01)/ DATA EX6/(8.66025403784439E-01, 5.E-01)/ DATA EX6C/(8.66025403784439E-01, -5.E-01)/ DATA CLN2/(0.0, 3.46573590279973E-01)/ DATA C1/5.64189583547756E-01/ DATA C2/3.98942280401433E-01/ DATA C3/7.07106781186548E-01/ C-------------------------- C C EPS AND XM ARE MACHINE DEPENDENT CONSTANTS. EPS IS THE C SMALLEST NUMBER SUCH THAT 1.0 + EPS .GT. 1.0, XPOS IS THE C LARGEST POSITIVE NUMBER FOR WHICH EXP(XM) CAN BE COMPUTED, C AND XNEG IS THE NEGATIVE NUMBER OF LARGEST MAGNITUDE FOR C WHICH EXP(X) DOES NOT UNDERFLOW. C EPS = SPMPAR(1) XPOS = EXPARG(0) XNEG = EXPARG(1) C C------------------------ IERR = 0 X = REAL(Z) Y = AIMAG(Z) IF (X .LT. ABS(Y)*SQT3) GO TO 30 C C ----- ABS(ARG(Z)) .LE. PI/6 ---- C Z1 = CSQRT(Z) Z2 = CSQRT(Z1) Z2R = 1.0/Z2 CALL CREC(X, Y, U, V) W = 1.5*CMPLX(U, V)/Z1 U = ABS(REAL(W)) V = ABS(AIMAG(W)) T = AMAX1(U, V) IF (IND .NE. 0) GO TO 10 IF (T .EQ. 0.0) GO TO 90 U1 = U/T V1 = V/T R = U*U1 + V*V1 IF (U1 .GE. R*XPOS .OR. V1 .GE. 0.1*R/EPS) GO TO 90 ZETA = Z1*Z/1.5 E = CEXP(ZETA) C 10 M = 20 T = AMAX1(X, ABS(Y)) IF (T .GT. 30.0) M = 8 S1 = CMPLX(C(M), 0.0) S2 = CMPLX(D(M), 0.0) I = M DO 20 K = 2,M I = I - 1 S1 = C(I) + W*S1 S2 = D(I) + W*S2 20 CONTINUE C BI = C1*Z2R*S1 BIP = C1*Z2*S2 IF (IND .NE. 0) RETURN BI = E*BI BIP = E*BIP RETURN 30 IF (X .LT. 0.0) GO TO 50 C C ---- PI/6 .LT. ABS(ARG(Z)) .LE. PI/2 ---- C CZ = Z IF (Y .LT. 0.0) CZ = CONJG(CZ) ZZ = CZ*EX3C Z1 = CSQRT(ZZ) Z2 = CSQRT(Z1) Z2R = 1.0/Z2 CF1 = C1*Z2R*EX6 CF2 = C1*Z2*EX6C CALL CREC(REAL(ZZ), AIMAG(ZZ), U, V) W = 1.5*CMPLX(U, V)/Z1 U = ABS(REAL(W)) V = ABS(AIMAG(W)) T = AMAX1(U, V) C IF (T .EQ. 0.0) GO TO 90 U1 = U/T V1 = V/T R = U*U1 + V*V1 IF (IND .NE. 0) GO TO 40 IF (V1 .GE. R*XPOS .OR. U1 .GE. 0.1*R/EPS) GO TO 90 ZETA = Z1*ZZ/1.5 CN = CCOS(ZETA - CLN2) SI = CSIN(ZETA - CLN2) GO TO 70 C C E = EXP(-2*I*(ZETA - CLN2)) IF ABS(ARG(ZZ)) .LE. PI/3 C E = EXP( 2*I*(ZETA - CLN2)) IF ABS(ARG(ZZ)) .GT. PI/3 C 40 E = (0.0, 0.0) J = (0.0, -1.0) S = 1.0 CE = 1.0 CF = 0.5 IF (AIMAG(ZZ) .LE. 0.0) GO TO 44 S = -1.0 CE = 0.5 CF = 2.0 44 IF (V1 .GE. 0.5*R*ABS(XNEG)) GO TO 45 IF (U1 .GE. 0.05*R/EPS) GO TO 90 ZETA = Z1*ZZ/1.5 E = CF*CEXP(2.0*S*J*ZETA) 45 CN = CE*C3*(1 + E) SI = CE*S*C3*(1 - E)*J GO TO 70 C C ---- REAL(Z) .LT. 0 ---- C 50 ZZ = -Z IF (Y .LT. 0.0) ZZ = CONJG(ZZ) Z1 = CSQRT(ZZ) Z2 = CSQRT(Z1) Z2R = 1.0/Z2 CF1 = C2*Z2R CF2 = C2*Z2 CALL CREC(REAL(ZZ), AIMAG(ZZ), U, V) W = 1.5*CMPLX(U, V)/Z1 U = ABS(REAL(W)) V = ABS(AIMAG(W)) T = AMAX1(U, V) C IF (T .EQ. 0.0) GO TO 90 U1 = U/T V1 = V/T R = U*U1 + V*V1 IF (IND .NE. 0) GO TO 60 IF (V1 .GE. R*XPOS .OR. U1 .GE. 0.1*R/EPS) GO TO 90 ZETA = Z1*ZZ/1.5 CN = CCOS(ZETA) SI = CSIN(ZETA) GO TO 70 60 E = (0.0, 0.0) J = (0.0, -1.0) IF (V1 .GE. 0.5*R*ABS(XNEG)) GO TO 65 IF (U1 .GE. 0.05*R/EPS) GO TO 90 ZETA = Z1*ZZ/1.5 E = CEXP(2.0*J*ZETA) 65 CN = 0.5*(1.0 + E) SI = 0.5*(1.0 - E)*J C 70 W2 = W*W M = 15 T = AMAX1(ABS(X), ABS(Y)) IF (T .GT. 30.0) M = 5 M2 = M + M I = M2 - 1 S1 = CMPLX(C(I), 0.0) S2 = CMPLX(C(M2), 0.0) S3 = CMPLX(D(I), 0.0) S4 = CMPLX(D(M2), 0.0) DO 80 K = 2,M I = I - 1 S2 = C(I) - S2*W2 S4 = D(I) - S4*W2 I = I - 1 S1 = C(I) - S1*W2 S3 = D(I) - S3*W2 80 CONTINUE S2 = W*S2 S4 = W*S4 IF (X .GE. 0.0) GO TO 81 ALPHA = S1 + S2 BETA = S2 - S1 GO TO 82 81 ALPHA = S1 - S2 BETA = S1 + S2 82 BI = CF1*(ALPHA*CN + BETA*SI) IF (X .GE. 0.0) GO TO 83 ALPHA = S3 - S4 BETA = S3 + S4 GO TO 84 83 ALPHA = S3 + S4 BETA = S4 - S3 84 BIP = CF2*(ALPHA*CN + BETA*SI) IF (Y .GE. 0.0) RETURN BI = CONJG(BI) BIP = CONJG(BIP) RETURN C C RETURN WITH ZERO VALUES IF SCALING IS NEEDED. C 90 BI = (0.0, 0.0) BIP = (0.0, 0.0) IERR = 1 RETURN END SUBROUTINE IA(Z, I1, I2, I1M, I2M) C------------------------------------------------------------- C CALCULATES THE MODIFIED BESSEL FUNCTION OF THE FIRST C KIND FOR ORDERS 1/3, 2/3, -1/3, AND -2/3 AND FOR COMPLEX C ARGUMENT Z, WHERE -PI .LT. ARG(Z) .LE. PI. I1 AND I2 C ARE REPLACED BY THE FUNCTIONS OF ORDERS 1/3 AND 2/3, C RESPECTIVELY, AND I1M AND I2M BY THE FUNCTIONS OF ORDERS C -1/3 AND -2/3, RESPECTIVELY. C------------------------------------------------------------- COMPLEX Z,I1,I2,I1M,I2M,CZ,EX13,EX13C,EX23,EX23C C C EX13 = EXP(I*PI/3) C EX13C = EXP(-I*PI/3) C EX23 = EXP(2*I*PI/3) C EX23C = EXP(-2*I*PI/3) C DATA EX13/(5.0E-01, 8.66025403784439E-01)/ DATA EX13C/(5.0E-01, -8.66025403784439E-01)/ DATA EX23/(-5.0E-01, 8.66025403784439E-01)/ DATA EX23C/(-5.0E-01, -8.66025403784439E-01)/ IF(REAL(Z) .GE. 0.0) GO TO 20 CZ = -Z C C CALCULATION OF I1, I2, I1M, AND I2M WHEN REAL(CZ) .GT. 0. C CALL IMC(CZ, I1, I2, I1M, I2M) C C FINAL ASSEMBLY C IF(AIMAG(Z) .LT. 0.0) GO TO 10 I1 = EX13*I1 I2 = EX23*I2 I1M = EX13C*I1M I2M = EX23C*I2M RETURN 10 I1 = EX13C*I1 I2 = EX23C*I2 I1M = EX13*I1M I2M = EX23*I2M RETURN 20 CALL IMC(Z, I1, I2, I1M, I2M) RETURN END SUBROUTINE IMC(Z, I1, I2, I1M, I2M) C---------------------------------------------------------------- C CALCULATES THE MODIFIED BESSEL FUNCTION OF THE FIRST C KIND FOR ORDERS 1/3, 2/3, -1/3, AND -2/3 AND FOR COMPLEX C ARGUMENT Z. THE MACLAURIN EXPANSION AND BACKWARD RECURRENCE C ARE USED. I1 AND I2 ARE REPLACED BY THE FUNCTIONS OF ORDERS C 1/3 AND 2/3, RESPECTIVELY, AND I1M AND I2M BY THE FUNCTIONS C OF ORDERS -1/3 AND -2/3, RESPECTIVELY. FOR GREATEST C ACCURACY, Z SHOULD LIE IN THE REGION REAL(Z) .GE. 0. C---------------------------------------------------------------- COMPLEX Z,IA1,IA2,IA3,IB1,IB2,IB3,I1,I2,I1M,I2M,SZ,ZH,E, * CF1,CF2,CF3,CF4 REAL M C C GM1 = GAMMA(4.0/3.0) C GM2 = GAMMA(5.0/3.0) C DATA C1/.333333333333333E+00/ DATA C2/.666666666666667E+00/ DATA GM1/.892979511569248E+00/ DATA GM2/.902745292950932E+00/ ZH = 0.5*Z SZ = ZH*ZH A = REAL(ZH) B = AIMAG(ZH) AN = AINT(A*A + B*B) CN1 = C1 + AN CN2 = C2 + AN C C CALCULATION OF INITIAL VALUES FOR BACKWARD RECURRENCE BY C USE OF THE MACLAURIN EXPANSION. C CALL BIM(Z, CN1, IA1) CALL BIM(Z, CN1 + 1.0, IA2) CALL BIM(Z, CN2, IB1) CALL BIM(Z, CN2 + 1.0, IB2) C C BACKWARD RECURRENCE C N = AN M = AN N1 = N + 1 DO 10 I = 1, N1 IA3 = IA2 IA2 = IA1 IB3 = IB2 IB2 = IB1 CFA = (M + C1)*(M + C1 + 1.0) CFB = (M + C2)*(M + C2 + 1.0) M = M - 1.0 IA1 = IA2 + (SZ/CFA)*IA3 10 IB1 = IB2 + (SZ/CFB)*IB3 E = CEXP(C1*CLOG(ZH)) CF1 = E/GM1 CF2 = E*E/GM2 CF3 = C2*CF2/ZH CF4 = C1*CF1/ZH I1 = CF1*IA2 I2 = CF2*IB2 I1M = CF3*IB1 I2M = CF4*IA1 RETURN END SUBROUTINE BIM(Z,CN,W) C------------------------------------------------------------- C CALCULATES THE MODIFIED BESSEL FUNCTION OF THE FIRST KIND C FOR REAL ORDER CN .GT. -1 AND COMPLEX ARGUMENT Z BY MEANS C OF THE MACLAURIN EXPANSION. W IS REPLACED BY THE C CALCULATED VALUE. C------------------------------------------------------------- REAL M COMPLEX Z, W, SZ, T C------------------ ANORM(Z) = AMAX1(ABS(REAL(Z)),ABS(AIMAG(Z))) C------------------------------------------------------------- C EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE SMALLEST C NUMBER SUCH THAT 1 + EPS .GT. 1. C EPS = SPMPAR(1) C C------------------------------------------------------------- SZ = 0.25*Z*Z C C INITIALIZATION OF MACLAURIN EXPANSION C M = 1.0 T = SZ/(CN + 1.0) W = T C C SUMMATION OF MACLAURIN EXPANSION C 10 M = M + 1.0 D = M*(CN + M) T = T*(SZ/D) W = W + T IF(ANORM(T) .GT. EPS*ANORM(W)) GO TO 10 C W = W + 1.0 RETURN END SUBROUTINE JA(Z, I1, I2, I1M, I2M) C------------------------------------------------------------ C CALCULATES THE BESSEL FUNCTION OF THE FIRST KIND FOR C ORDERS 1/3, 2/3, -1/3, AND -2/3 AND FOR COMPLEX ARGUMENT C Z, WHERE -PI .LT. ARG(Z) .LE. PI. I1 AND I2 ARE REPLACED C BY THE FUNCTIONS OF ORDERS 1/3 AND 2/3, RESPECTIVELY, AND C I1M AND I2M BY FUNCTIONS OF ORDERS -1/3 AND -2/3, C RESPECTIVELY. C-------------------------------------------------------------- COMPLEX Z,I1,I2,I1M,I2M,CZ,EX13,EX13C,EX23,EX23C C C EX13 = EXP(I*PI/3) C EX13C = EXP(-I*PI/3) C EX23 = EXP(2*I*PI/3) C EX23C = EXP(-2*I*PI/3) C DATA EX13/(5.0E-01, 8.66025403784439E-01)/ DATA EX13C/(5.0E-01, -8.66025403784439E-01)/ DATA EX23/(-5.0E-01, 8.66025403784439E-01)/ DATA EX23C/(-5.0E-01, -8.66025403784439E-01)/ IF(REAL(Z) .GE. 0.0) GO TO 20 CZ = -Z C C CALCULATION OF I1, I2, I1M, AND I2M WHEN REAL(CZ) .GT. 0.0 C CALL JMC(CZ, I1, I2, I1M, I2M) C C FINAL ASSEMBLY C IF(AIMAG(Z) .LT. 0.0) GO TO 10 I1 = EX13*I1 I2 = EX23*I2 I1M = EX13C*I1M I2M = EX23C*I2M RETURN 10 I1 = EX13C*I1 I2 = EX23C*I2 I1M = EX13*I1M I2M = EX23*I2M RETURN 20 CALL JMC(Z, I1, I2, I1M, I2M) RETURN END SUBROUTINE JMC(Z, I1, I2, I1M, I2M) C---------------------------------------------------------------- C CALCULATES THE BESSEL FUNCTION OF THE FIRST C KIND FOR ORDERS 1/3, 2/3, -1/3, AND -2/3 AND FOR COMPLEX C ARGUMENT Z. THE MACLAURIN EXPANSION AND BACKWARD RECURRENCE C ARE USED. I1 AND I2 ARE REPLACED BY THE FUNCTIONS OF ORDERS C 1/3 AND 2/3, RESPECTIVELY, AND I1M AND I2M BY THE FUNCTIONS C OF ORDERS -1/3 AND -2/3, RESPECTIVELY. FOR GREATEST C ACCURACY, Z SHOULD LIE IN THE REGION REAL(Z) .GE. 0. C---------------------------------------------------------------- COMPLEX Z,IA1,IA2,IA3,IB1,IB2,IB3,I1,I2,I1M,I2M,SZ,ZH,E, * CF1,CF2,CF3,CF4 REAL M C C GM1 = GAMMA(4.0/3.0) C GM2 = GAMMA(5.0/3.0) C DATA C1/.333333333333333E+00/ DATA C2/.666666666666667E+00/ DATA GM1/.892979511569248E+00/ DATA GM2/.902745292950932E+00/ ZH = 0.5*Z SZ = ZH*ZH A = REAL(ZH) B = AIMAG(ZH) AN = AINT(A*A + B*B) CN1 = C1 + AN CN2 = C2 + AN C C CALCULATION OF INITIAL VALUES FOR BACKWARD RECURRENCE BY C USE OF THE MACLAURIN EXPANSION. C CALL BJM(Z, CN1, IA1) CALL BJM(Z, CN1 + 1.0, IA2) CALL BJM(Z, CN2, IB1) CALL BJM(Z, CN2 + 1.0, IB2) C C BACKWARD RECURRENCE C N = AN N1 = N + 1 M = AN DO 10 I = 1, N1 IA3 = IA2 IA2 = IA1 IB3 = IB2 IB2 = IB1 CFA = (M + C1)*(M + C1 + 1.0) CFB = (M + C2)*(M + C2 + 1.0) M = M - 1.0 IA1 = IA2 - (SZ/CFA)*IA3 10 IB1 = IB2 - (SZ/CFB)*IB3 E = CEXP(C1*CLOG(ZH)) CF1 = E/GM1 CF2 = E*E/GM2 CF3 = C2*CF2/ZH CF4 = C1*CF1/ZH I1 = CF1*IA2 I2 = CF2*IB2 I1M = CF3*IB1 I2M = CF4*IA1 RETURN END SUBROUTINE BJM(Z,CN,W) C------------------------------------------------------------- C CALCULATES THE BESSEL FUNCTION OF THE FIRST KIND C FOR REAL ORDER CN .GT. -1 AND COMPLEX ARGUMENT Z BY MEANS C OF THE MACLAURIN EXPANSION. W IS REPLACED BY THE C CALCULATED VALUE. C------------------------------------------------------------- REAL M COMPLEX Z, W, SZ, T C------------------ ANORM(Z) = AMAX1(ABS(REAL(Z)),ABS(AIMAG(Z))) C------------------------------------------------------------- C EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE SMALLEST C NUMBER SUCH THAT 1 + EPS .GT. 1. C EPS = SPMPAR(1) C C------------------------------------------------------------- SZ = -0.25*Z*Z C C INITIALIZATION OF MACLAURIN EXPANSION C M = 1.0 T = SZ/(CN + 1.0) W = T C C SUMMATION OF MACLAURIN EXPANSION C 10 M = M + 1.0 D = M*(CN + M) T = T*(SZ/D) W = W + T IF(ANORM(T) .GT. EPS*ANORM(W)) GO TO 10 C W = W + 1.0 RETURN END SUBROUTINE KA(IND, Z, K1, K2) C------------------------------------------------------------ C CALCULATES THE MODIFIED BESSEL FUNCTION OF THE SECOND C KIND FOR ORDERS 1/3 AND 2/3 AND FOR COMPLEX ARGUMENT Z, C WHERE -PI .LT. ARG(Z) .LE PI. K1 IS REPLACED BY THE C FUNCTION OF ORDER 1/3, AND K2 BY THE FUNCTION OF ORDER C 2/3. C------------------------------------------------------------ COMPLEX Z,K1,K2,I1,I2,I1M,I2M,CZ,EX13C,EX23C,J,E C C EX13C = EXP(-PI*I/3) C EX23C = EXP(-2*PI*I/3) C DATA PI/3.14159265358979E+00/ DATA EX13C/(5.0E-01, -8.66025403784439E-01)/ DATA EX23C/(-5.0E-01, -8.66025403784439E-01)/ DATA J/(0.0, 1.0)/ A = REAL(Z) B = AIMAG(Z) IF (ABS(B) .LT. -0.5*A) GO TO 10 C C ---- ABS(B) .GE. -0.5*A ---- C CALL KML(IND, Z, K1, K2) RETURN C C ---- ABS(B) .LT. -0.5*A ---- C 10 CZ = -Z IF(AIMAG(Z) .LT. 0.0) CZ = CONJG(CZ) IND1 = 0 CALL KML(IND1, CZ, K1, K2) CALL IMC(CZ, I1, I2, I1M, I2M) K1 = EX13C*K1 - J*PI*I1 K2 = EX23C*K2 - J*PI*I2 IF (IND .EQ. 0) GO TO 20 E = CEXP(Z) K1 = K1*E K2 = K2*E 20 IF(AIMAG(Z) .GE. 0.0) RETURN K1 = CONJG(K1) K2 = CONJG(K2) RETURN END SUBROUTINE KML(IND, Z, K1, K2) C------------------------------------------------------------ C CALCULATES THE MODIFIED BESSEL FUNCTION OF THE SECOND C KIND FOR ORDERS 1/3 AND 2/3 AND FOR COMPLEX ARGUMENT Z C BY USE OF THE MILLER ALGORITHM. K1 IS REPLACED BY THE C FUNCTION OF ORDER 1/3, AND K2 BY THE FUNCTION OF ORDER C 2/3. FOR GREATEST ACCURACY, Z SHOULD LIE IN THE REGION C REAL(Z) .GE. 0. C------------------------------------------------------------ COMPLEX Z, K1, K2, BI, U1, U2, U3, S, E C C C1 = SQRT(PI/2) C DATA C1/1.25331413731550E+00/ EPS = SPMPAR(1) X1 = REAL(Z) X2 = AIMAG(Z) C C CALCULATION OF M FOR USE IN MILLER ALGORITHM. C CALL CAPO(X1, X2, R, TH) A = 3.0/(1.0 + R) B = 14.7/(28.0 + R) C = 2.0/(C1*EPS*(2.0*R)**(0.25)) M = (0.485/R)*(ALOG(C) + R*COS(A*TH)/(1.0 + 0.008*R))**2/ 1 (2.0*COS(B*TH))**2 + 1.5 C C BACKWARD RECURRENCE IN MILLER ALGORITHM. C S = 0.0 U2 = 0.0 U1 = EPS L = M DO 10 I = 1, M AL = L U3 = U2 U2 = U1 AI = ((AL - 0.5)**2 - 1.0/9.0)/(AL*(AL + 1.0)) BI = 2.0*(AL + Z)/(AL + 1.0) U1 = (BI*U2 - U3)/AI S = S + U1 10 L = L - 1 C C FINAL ASSEMBLY C K1 = C1*U1/(S*CSQRT(Z)) K2 = K1*(Z + 1.0/6.0 - U2/U1)/Z IF (IND .NE. 0) RETURN E = CEXP(-Z) K1 = K1*E K2 = K2*E RETURN END REAL FUNCTION AI(X) C----------------------------------------------------------------------- C EVALUATION OF THE AIRY FUNCTION AI(X) C----------------------------------------------------------------------- C X0 = 2**(2/3) C C = EXP(2/3) C----------------------- DATA X0/1.58740105196820/ DATA C /1.94773404105468/ C----------------------- DATA AN0/ .355028053887818E+00/, AN1/-.187394912983414E+00/, * AN2/-.383735973881972E-01/, AN3/ .491952571236878E-01/, * AN4/-.967017625191329E-02/, AN5/-.205648610308316E-02/, * AN6/ .114176040526844E-02/, AN7/-.117114823456866E-03/, * AN8/-.270165470074755E-04/, AN9/ .789002965889206E-05/ DATA AD0/ .100000000000000E+01/, AD1/ .201179850513612E+00/, * AD2/ .385762517106249E-01/, AD3/ .230887443780120E-04/ C----------------------- DATA BN0/ .355028053887817E+00/, BN1/-.997169317338190E-01/, * BN2/-.602216060213075E-01/, BN3/ .297705337630730E-01/, * BN4/-.152969932286570E-02/, BN5/-.147868368189372E-02/, * BN6/ .350518617006107E-03/, BN7/-.257766924610873E-04/ DATA BD0/.100000000000000E+01/, BD1/.448140563306831E+00/, * BD2/.157074537566686E+00/, BD3/.316964519364865E-01/, * BD4/.485922740843953E-02/, BD5/.423326964456309E-03/ C----------------------- DATA PN0/.282094378896566E+00/, PN1/.807868561687271E-01/, * PN2/.630644564152247E-02/, PN3/.147116711467936E-03/, * PN4/.750490748341483E-06/ DATA PD0/.100000000000000E+01/, PD1/.292890323271551E+00/, * PD2/.239376862143358E-01/, PD3/.612353984250624E-03/, * PD4/.384461189764830E-05/, PD5/.123247804102182E-08/ C----------------------- DATA QN0/.282094791017188E+00/, QN1/.149585822742689E+00/, * QN2/.241876418864958E-01/, QN3/.138190913282142E-02/, * QN4/.241862862465003E-04/, QN5/.709733720554615E-07/ DATA QD0/.100000000000000E+01/, QD1/.536778341756648E+00/, * QD2/.889112579703465E-01/, QD3/.533368703697049E-02/, * QD4/.103812739863315E-03/, QD5/.408838544650398E-06/ C----------------------- DATA RN0/.282094791773878E+00/, RN1/.203731967781874E+00/, * RN2/.436660479870037E-01/, RN3/.306595563073142E-02/, * RN4/.517398800281618E-04/ DATA RD0/.100000000000000E+01/, RD1/.728721438361672E+00/, * RD2/.159210021472267E+00/, RD3/.116985268534248E-01/, * RD4/.225973894323078E-03/, RD5/.232707159780478E-06/ C----------------------------------------------------------------------- IF (X .GE. -1.0) GO TO 10 CALL AIMP (-X, R, PHI) AI = R*SIN(PHI) RETURN C 10 IF (X .GE. 0.0) GO TO 20 AI = (((((((((AN9*X + AN8)*X + AN7)*X + AN6)*X + AN5)*X * + AN4)*X + AN3)*X + AN2)*X + AN1)*X + AN0) / * (((AD3*X + AD2)*X + AD1)*X + AD0) RETURN C 20 IF (X .GE. 1.0) GO TO 30 AI = (((((((BN7*X + BN6)*X + BN5)*X + BN4)*X + BN3)*X + BN2)*X * + BN1)*X + BN0) / * (((((BD5*X + BD4)*X + BD3)*X + BD2)*X + BD1)*X + BD0) RETURN C 30 RTX = SQRT(X) IF (X .GT. X0) GO TO 40 T = 16.0/(X*RTX) W = ((((PN4*T + PN3)*T + PN2)*T + PN1)*T + PN0) / * (((((PD5*T + PD4)*T + PD3)*T + PD2)*T + PD1)*T + PD0) AI = (W/SQRT(RTX)) * EXP(-2.0*X*RTX/3.0) RETURN C 40 IF (X .GT. 4.0D0) GO TO 50 T = 16.0/(X*RTX) W = (((((QN5*T + QN4)*T + QN3)*T + QN2)*T + QN1)*T + QN0) / * (((((QD5*T + QD4)*T + QD3)*T + QD2)*T + QD1)*T + QD0) AI = (W/SQRT(RTX)) * EXP(-2.0*X*RTX/3.0) RETURN C 50 IF (X*RTX .GT. 1.5*EXPARG(0)) GO TO 60 T = 16.0/(X*RTX) W = ((((RN4*T + RN3)*T + RN2)*T + RN1)*T + RN0) / * (((((RD5*T + RD4)*T + RD3)*T + RD2)*T + RD1)*T + RD0) N = RTX N2 = N*N T = (X - N2)/(RTX + N) AI = ((W/SQRT(RTX)) / C**(N2*N)) * EXP(-2.0*T*(N*RTX + T*T/3.0)) RETURN C 60 AI = 0.0 RETURN END REAL FUNCTION AIE(X) C----------------------------------------------------------------------- C C SCALED AIRY FUNCTION AI(X) C C C AIE(X) = EXP(ZETA)*AI(X) WHEN X .GE. 0 C AIE(X) = AI(X) WHEN X .LT. 0 C C ZETA = (2/3) * X**(3/2) C C----------------------------------------------------------------------- C X0 = 2**(2/3) C----------------------- DATA X0/.158740105196820E+01/ C----------------------- DATA AN0/ .355028053887818E+00/, AN1/-.187394912983414E+00/, * AN2/-.383735973881972E-01/, AN3/ .491952571236878E-01/, * AN4/-.967017625191329E-02/, AN5/-.205648610308316E-02/, * AN6/ .114176040526844E-02/, AN7/-.117114823456866E-03/, * AN8/-.270165470074755E-04/, AN9/ .789002965889206E-05/ DATA AD0/ .100000000000000E+01/, AD1/ .201179850513612E+00/, * AD2/ .385762517106249E-01/, AD3/ .230887443780120E-04/ C----------------------- DATA BN0/ .355028053887817E+00/, BN1/-.997169317338190E-01/, * BN2/-.602216060213075E-01/, BN3/ .297705337630730E-01/, * BN4/-.152969932286570E-02/, BN5/-.147868368189372E-02/, * BN6/ .350518617006107E-03/, BN7/-.257766924610873E-04/ DATA BD0/.100000000000000E+01/, BD1/.448140563306831E+00/, * BD2/.157074537566686E+00/, BD3/.316964519364865E-01/, * BD4/.485922740843953E-02/, BD5/.423326964456309E-03/ C----------------------- DATA PN0/.282094378896566E+00/, PN1/.807868561687271E-01/, * PN2/.630644564152247E-02/, PN3/.147116711467936E-03/, * PN4/.750490748341483E-06/ DATA PD0/.100000000000000E+01/, PD1/.292890323271551E+00/, * PD2/.239376862143358E-01/, PD3/.612353984250624E-03/, * PD4/.384461189764830E-05/, PD5/.123247804102182E-08/ C----------------------- DATA QN0/.282094791017188E+00/, QN1/.149585822742689E+00/, * QN2/.241876418864958E-01/, QN3/.138190913282142E-02/, * QN4/.241862862465003E-04/, QN5/.709733720554615E-07/ DATA QD0/.100000000000000E+01/, QD1/.536778341756648E+00/, * QD2/.889112579703465E-01/, QD3/.533368703697049E-02/, * QD4/.103812739863315E-03/, QD5/.408838544650398E-06/ C----------------------- DATA RN0/.282094791773878E+00/, RN1/.203731967781874E+00/, * RN2/.436660479870037E-01/, RN3/.306595563073142E-02/, * RN4/.517398800281618E-04/ DATA RD0/.100000000000000E+01/, RD1/.728721438361672E+00/, * RD2/.159210021472267E+00/, RD3/.116985268534248E-01/, * RD4/.225973894323078E-03/, RD5/.232707159780478E-06/ C----------------------------------------------------------------------- IF (X .GE. -1.0) GO TO 10 CALL AIMP (-X, R, PHI) AIE = R*SIN(PHI) RETURN C 10 IF (X .GE. 0.0) GO TO 20 AIE = (((((((((AN9*X + AN8)*X + AN7)*X + AN6)*X + AN5)*X * + AN4)*X + AN3)*X + AN2)*X + AN1)*X + AN0) / * (((AD3*X + AD2)*X + AD1)*X + AD0) RETURN C 20 IF (X .GE. 1.0) GO TO 30 AIE = (((((((BN7*X + BN6)*X + BN5)*X + BN4)*X + BN3)*X + BN2)*X * + BN1)*X + BN0) / * (((((BD5*X + BD4)*X + BD3)*X + BD2)*X + BD1)*X + BD0) IF (X .GT. 1.E-20) AIE = AIE * EXP(2.0*X*SQRT(X)/3.0) RETURN C 30 RTX = SQRT(X) IF (X .GT. X0) GO TO 40 T = 16.0/(X*RTX) W = ((((PN4*T + PN3)*T + PN2)*T + PN1)*T + PN0) / * (((((PD5*T + PD4)*T + PD3)*T + PD2)*T + PD1)*T + PD0) AIE = W/SQRT(RTX) RETURN C 40 IF (X .GT. 4.0D0) GO TO 50 T = 16.0/(X*RTX) W = (((((QN5*T + QN4)*T + QN3)*T + QN2)*T + QN1)*T + QN0) / * (((((QD5*T + QD4)*T + QD3)*T + QD2)*T + QD1)*T + QD0) AIE = W/SQRT(RTX) RETURN C 50 IF (X .GT. 1.E20) GO TO 60 T = 16.0/(X*RTX) W = ((((RN4*T + RN3)*T + RN2)*T + RN1)*T + RN0) / * (((((RD5*T + RD4)*T + RD3)*T + RD2)*T + RD1)*T + RD0) AIE = W/SQRT(RTX) RETURN C 60 AIE = RN0/SQRT(RTX) RETURN END REAL FUNCTION BI(X) C----------------------------------------------------------------------- C C EVALUATION OF THE AIRY FUNCTION BI(X) C C C NOTE... IF X IS A POSITIVE NUMBER WHERE BI(X) IS TOO LARGE C TO BE COMPUTED, THEN BI(X) IS SET TO 0. C C----------------------------------------------------------------------- C X0 = 16**(2/3) C C = EXP(2/3) C----------------------- DATA X0/6.3496042078728/ DATA C /1.94773404105468/ C----------------------- DATA AN0/ .614926627446001E+00/, AN1/ .462726943978834E+00/, * AN2/ .867811386408974E-02/, AN3/ .974670609357959E-01/, * AN4/ .370856545413908E-01/, AN5/ .569193415071716E-03/, * AN6/ .269172131237236E-02/, AN7/ .746473849872868E-03/, * AN8/ .105638036899269E-04/, AN9/ .242726195973978E-04/, * AN10/.557260250681542E-05/ DATA AD0/ .100000000000000E+01/, AD1/ .234801779278695E-01/, * AD2/-.300487317759152E-02/, AD3/-.597414466459612E-02/ C----------------------- DATA BN0/ .614926627446001E+00/, BN1/ .548653374523520E+00/, * BN2/ .582684047163842E-01/, BN3/ .871954925712688E-01/, * BN4/ .508547058449004E-01/, BN5/ .361412623711710E-02/, * BN6/ .177269722794511E-02/, BN7/ .117774184027185E-02/, * BN8/ .627004834186143E-04/, BN9/ .774782269814080E-06/, * BN10/.118116474369315E-04/ DATA BD0/ .100000000000000E+01/, BD1/ .163214622184402E+00/, * BD2/-.242285981710408E-01/, BD3/-.720554280297616E-02/ C----------------------- DATA PN0/.619911943572678E+00/, PN1/.100411558489626E+01/, * PN2/.563659963795768E+00/, PN3/.274925508033015E+00/, * PN4/.115641822943246E+00/, PN5/.120048517441127E-01/, * PN6/.501838091254330E-02/ DATA PD0/.100000000000000E+01/, PD1/.159751878026937E+01/, * PD2/.104664867034140E+01/, PD3/.512560333664022E+00/, * PD4/.159144727666995E+00/, PD5/.394456748956258E-01/, * PD6/.529926873250079E-02/, PD7/.288921845412576E-03/ C----------------------- DATA QN0/.595123543430856E+00/, QN1/.652692120245803E+00/, * QN2/.436851872835894E+00/, QN3/.201626141057807E+00/, * QN4/.649535170626944E-01/, QN5/.171798867787816E-01/, * QN6/.287998748038892E-02/, QN7/.359634362348937E-03/ DATA QD0/.100000000000000E+01/, QD1/.114259871204893E+01/, * QD2/.766390439057101E+00/, QD3/.348287281255683E+00/, * QD4/.117049276946157E+00/, QD5/.294545450289541E-01/, * QD6/.523951773968125E-02/, QD7/.622692248774973E-03/, * QD8/.674811395957744E-06/ C----------------------- DATA RN0 / .568067636505865E+00/, RN1 / .462183136291541E-01/, * RN2 / .268519638203645E+00/, RN3 / .199427104235673E-02/, * RN4 / .135599161332010E-03/, RN5 / .229937707171804E-04/, * RN6 / .697888081361175E-05/, RN7 / .153277172934286E-05/, * RN8 /-.149322381877245E-05/, RN9 /-.113533571972859E-05/, * RN10/ .740721412702102E-06/, RN11/-.120160431596119E-06/ DATA RD0 / .100000000000000E+01/, RD1 / .741293424676788E-01/, * RD2 / .471695968238457E+00/ C----------------------- DATA SN0 /.564189583547757E+00/, SN1 / .112605519585866E+00/, * SN2 /.893329124921909E-03/, SN3 / .532139134120350E-04/, * SN4 /.592725458717738E-05/, SN5 / .921448923850546E-06/, * SN6 /.404558310611815E-06/, SN7 /-.660517686759109E-06/, * SN8 /.174667472383815E-05/, SN9 /-.287037710548882E-05/, * SN10/.322304072982791E-05/, SN11/-.231569499551950E-05/, * SN12/.963478964685941E-06/, SN13/-.173784488565533E-06/ DATA SD0 /.100000000000000E+01/, SD1 / .193077670156841E+00/ C----------------------------------------------------------------------- IF (X .GE. -1.0) GO TO 10 CALL AIMP (-X, R, PHI) BI = R*COS(PHI) RETURN C 10 IF (X .GE. 0.0) GO TO 20 BI = ((((((((((AN10*X + AN9)*X + AN8)*X + AN7)*X * + AN6)*X + AN5)*X + AN4)*X + AN3)*X * + AN2)*X + AN1)*X + AN0) / * (((AD3*X + AD2)*X + AD1)*X + AD0) RETURN C 20 IF (X .GT. 1.0) GO TO 30 BI = ((((((((((BN10*X + BN9)*X + BN8)*X + BN7)*X * + BN6)*X + BN5)*X + BN4)*X + BN3)*X * + BN2)*X + BN1)*X + BN0) / * (((BD3*X + BD2)*X + BD1)*X + BD0) RETURN C 30 RTX = SQRT(X) IF (X .GT. 2.0) GO TO 40 T = X - 1.0 W = ((((((PN6*T + PN5)*T + PN4)*T + PN3)*T + PN2)*T * + PN1)*T + PN0) / * (((((((PD7*T + PD6)*T + PD5)*T + PD4)*T + PD3)*T * + PD2)*T + PD1)*T + PD0) BI = (W/SQRT(RTX)) * EXP(2.0*X*RTX/3.0) RETURN C 40 IF (X .GT. 4.0) GO TO 50 T = X - 2.0 W = (((((((QN7*T + QN6)*T + QN5)*T + QN4)*T + QN3)*T * + QN2)*T + QN1)*T + QN0) / * ((((((((QD8*T + QD7)*T + QD6)*T + QD5)*T + QD4)*T * + QD3)*T + QD2)*T + QD1)*T + QD0) BI = (W/SQRT(RTX)) * EXP(2.0*X*RTX/3.0) RETURN C 50 IF (X .GT. X0) GO TO 60 T = 16.0/(X*RTX) - 1.0 W = (((((((((((RN11*T + RN10)*T + RN9)*T + RN8)*T * + RN7)*T + RN6)*T + RN5)*T + RN4)*T + RN3)*T * + RN2)*T + RN1)*T + RN0) / * ((RD2*T + RD1)*T + RD0) BI = (W/SQRT(RTX)) * EXP(2.0*X*RTX/3.0) RETURN C 60 IF (X*RTX .GT. 1.5*EXPARG(0)) GO TO 70 T = 16.0/(X*RTX) W = (((((((((((((SN13*T + SN12)*T + SN11)*T + SN10)*T * + SN9)*T + SN8)*T + SN7)*T + SN6)*T + SN5)*T * + SN4)*T + SN3)*T + SN2)*T + SN1)*T + SN0) / * (SD1*T + SD0) N = RTX N2 = N*N T = (X - N2)/(RTX + N) BI = (W/SQRT(RTX)) * C**(N2*N) * EXP(2.0*T*(N*RTX + T*T/3.0)) RETURN C 70 BI = 0.0 RETURN END REAL FUNCTION BIE(X) C----------------------------------------------------------------------- C C SCALED AIRY FUNCTION BI(X) C C C BIE(X) = EXP(-ZETA)*BI(X) WHEN X .GE. 0 C BIE(X) = BI(X) WHEN X .LT. 0 C C ZETA = (2/3) * X**(3/2) C C----------------------------------------------------------------------- C X0 = 16**(2/3) C----------------------- DATA X0/6.3496042078728/ C----------------------- DATA AN0/ .614926627446001E+00/, AN1/ .462726943978834E+00/, * AN2/ .867811386408974E-02/, AN3/ .974670609357959E-01/, * AN4/ .370856545413908E-01/, AN5/ .569193415071716E-03/, * AN6/ .269172131237236E-02/, AN7/ .746473849872868E-03/, * AN8/ .105638036899269E-04/, AN9/ .242726195973978E-04/, * AN10/.557260250681542E-05/ DATA AD0/ .100000000000000E+01/, AD1/ .234801779278695E-01/, * AD2/-.300487317759152E-02/, AD3/-.597414466459612E-02/ C----------------------- DATA BN0/ .614926627446001E+00/, BN1/ .548653374523520E+00/, * BN2/ .582684047163842E-01/, BN3/ .871954925712688E-01/, * BN4/ .508547058449004E-01/, BN5/ .361412623711710E-02/, * BN6/ .177269722794511E-02/, BN7/ .117774184027185E-02/, * BN8/ .627004834186143E-04/, BN9/ .774782269814080E-06/, * BN10/.118116474369315E-04/ DATA BD0/ .100000000000000E+01/, BD1/ .163214622184402E+00/, * BD2/-.242285981710408E-01/, BD3/-.720554280297616E-02/ C----------------------- DATA PN0/.619911943572678E+00/, PN1/.100411558489626E+01/, * PN2/.563659963795768E+00/, PN3/.274925508033015E+00/, * PN4/.115641822943246E+00/, PN5/.120048517441127E-01/, * PN6/.501838091254330E-02/ DATA PD0/.100000000000000E+01/, PD1/.159751878026937E+01/, * PD2/.104664867034140E+01/, PD3/.512560333664022E+00/, * PD4/.159144727666995E+00/, PD5/.394456748956258E-01/, * PD6/.529926873250079E-02/, PD7/.288921845412576E-03/ C----------------------- DATA QN0/.595123543430856E+00/, QN1/.652692120245803E+00/, * QN2/.436851872835894E+00/, QN3/.201626141057807E+00/, * QN4/.649535170626944E-01/, QN5/.171798867787816E-01/, * QN6/.287998748038892E-02/, QN7/.359634362348937E-03/ DATA QD0/.100000000000000E+01/, QD1/.114259871204893E+01/, * QD2/.766390439057101E+00/, QD3/.348287281255683E+00/, * QD4/.117049276946157E+00/, QD5/.294545450289541E-01/, * QD6/.523951773968125E-02/, QD7/.622692248774973E-03/, * QD8/.674811395957744E-06/ C----------------------- DATA RN0 / .568067636505865E+00/, RN1 / .462183136291541E-01/, * RN2 / .268519638203645E+00/, RN3 / .199427104235673E-02/, * RN4 / .135599161332010E-03/, RN5 / .229937707171804E-04/, * RN6 / .697888081361175E-05/, RN7 / .153277172934286E-05/, * RN8 /-.149322381877245E-05/, RN9 /-.113533571972859E-05/, * RN10/ .740721412702102E-06/, RN11/-.120160431596119E-06/ DATA RD0 / .100000000000000E+01/, RD1 / .741293424676788E-01/, * RD2 / .471695968238457E+00/ C----------------------- DATA SN0 /.564189583547757E+00/, SN1 / .112605519585866E+00/, * SN2 /.893329124921909E-03/, SN3 / .532139134120350E-04/, * SN4 /.592725458717738E-05/, SN5 / .921448923850546E-06/, * SN6 /.404558310611815E-06/, SN7 /-.660517686759109E-06/, * SN8 /.174667472383815E-05/, SN9 /-.287037710548882E-05/, * SN10/.322304072982791E-05/, SN11/-.231569499551950E-05/, * SN12/.963478964685941E-06/, SN13/-.173784488565533E-06/ DATA SD0 /.100000000000000E+01/, SD1 / .193077670156841E+00/ C----------------------------------------------------------------------- IF (X .GE. -1.0) GO TO 10 CALL AIMP (-X, R, PHI) BIE = R*COS(PHI) RETURN C 10 IF (X .GE. 0.0) GO TO 20 BIE = ((((((((((AN10*X + AN9)*X + AN8)*X + AN7)*X * + AN6)*X + AN5)*X + AN4)*X + AN3)*X * + AN2)*X + AN1)*X + AN0) / * (((AD3*X + AD2)*X + AD1)*X + AD0) RETURN C 20 IF (X .GT. 1.0) GO TO 30 BIE = ((((((((((BN10*X + BN9)*X + BN8)*X + BN7)*X * + BN6)*X + BN5)*X + BN4)*X + BN3)*X * + BN2)*X + BN1)*X + BN0) / * (((BD3*X + BD2)*X + BD1)*X + BD0) IF (X .GT. 1.E-20) BIE = BIE * EXP(-2.0*X*SQRT(X)/3.0) RETURN C 30 RTX = SQRT(X) IF (X .GT. 2.0) GO TO 40 T = X - 1.0 W = ((((((PN6*T + PN5)*T + PN4)*T + PN3)*T + PN2)*T * + PN1)*T + PN0) / * (((((((PD7*T + PD6)*T + PD5)*T + PD4)*T + PD3)*T * + PD2)*T + PD1)*T + PD0) BIE = W/SQRT(RTX) RETURN C 40 IF (X .GT. 4.0) GO TO 50 T = X - 2.0 W = (((((((QN7*T + QN6)*T + QN5)*T + QN4)*T + QN3)*T * + QN2)*T + QN1)*T + QN0) / * ((((((((QD8*T + QD7)*T + QD6)*T + QD5)*T + QD4)*T * + QD3)*T + QD2)*T + QD1)*T + QD0) BIE = W/SQRT(RTX) RETURN C 50 IF (X .GT. X0) GO TO 60 T = 16.0/(X*RTX) - 1.0 W = (((((((((((RN11*T + RN10)*T + RN9)*T + RN8)*T * + RN7)*T + RN6)*T + RN5)*T + RN4)*T + RN3)*T * + RN2)*T + RN1)*T + RN0) / * ((RD2*T + RD1)*T + RD0) BIE = W/SQRT(RTX) RETURN C 60 IF (X .GT. 1.E20) GO TO 70 T = 16.0/(X*RTX) W = (((((((((((((SN13*T + SN12)*T + SN11)*T + SN10)*T * + SN9)*T + SN8)*T + SN7)*T + SN6)*T + SN5)*T * + SN4)*T + SN3)*T + SN2)*T + SN1)*T + SN0) / * (SD1*T + SD0) BIE = W/SQRT(RTX) RETURN C 70 BIE = SN0/SQRT(RTX) RETURN END SUBROUTINE AIMP (X, R, PHI) C----------------------------------------------------------------------- C COMPUTATION OF THE AIRY MODULUS AND PHASE FOR X .GE. 1 C----------------------------------------------------------------------- DATA PI4 /.785398163397448/ C----------------------- DATA AN0/.297640916735064E+00/, AN1/.772796814419809E+00/, * AN2/.764990563560236E+00/, AN3/.375694096095838E+00/, * AN4/.978661044870204E-01/, AN5/.110446639522696E-01/, * AN6/.145271249611697E-05/ DATA AD0/.100000000000000E+01/, AD1/.247380029946443E+01/, * AD2/.240125897828762E+01/, AD3/.118267264172257E+01/, * AD4/.306942883081787E+00/, AD5/.347670057203535E-01/ C----------------------- DATA BN0/.593601051670149E+00/, BN1/.223281495955754E+01/, * BN2/.317718143418600E+01/, BN3/.229890914530923E+01/, * BN4/.933580623665765E+00/, BN5/.209164380960390E+00/, * BN6/.207910965366403E-01/ DATA BD0/.100000000000000E+01/, BD1/.345985556561483E+01/, * BD2/.479629661187354E+01/, BD3/.345429311552596E+01/, * BD4/.140017214942186E+01/, BD5/.313770549939860E+00/, * BD6/.311852186700025E-01/ C----------------------- DATA CN0/.313541841678871E+00/, CN1/.470104287134296E+00/, * CN2/.291795874641314E+00/, CN3/.962250689852768E-01/, * CN4/.171024484244850E-01/, CN5/.134933201907052E-02/ DATA CD0/.100000000000000E+01/, CD1/.148070947673639E+01/, * CD2/.917484386216329E+00/, CD3/.302281922152536E+00/, * CD4/.537309296828367E-01/, CD5/.423890576557513E-02/, * CD6/.525954318463502E-08/ C----------------------- DATA DN0/.654836896032068E+00/, DN1/.117099614856528E+01/, * DN2/.831899010444840E+00/, DN3/.301060337976575E+00/, * DN4/.564712748150658E-01/, DN5/.444134415666317E-02/ DATA DD0/.100000000000000E+01/, DD1/.176306543768126E+01/, * DD2/.124897609613487E+01/, DD3/.451576491257036E+00/, * DD4/.847085955634988E-01/, DD5/.666188176245820E-02/, * DD6/.537600060708764E-08/ C----------------------- DATA PN0/.318309886183791E+00/, PN1/.100996327221962E+01/, * PN2/.902315148591491E+00/, PN3/.259820640977615E+00/, * PN4/.203717769716282E-01/, PN5/.216893438784765E-03/ DATA PD0/.100000000000000E+01/, PD1/.317533460265059E+01/, * PD2/.284232123705698E+01/, PD3/.822777439238360E+00/, * PD4/.656865942543526E-01/, PD5/.775376048996392E-03/ C----------------------- DATA QN0/.666666666666667E+00/, QN1/.141905542385598E+01/, * QN2/.772778148352443E+00/, QN3/.115170415082442E+00/, * QN4/.326457319318373E-02/ DATA QD0/.100000000000000E+01/, QD1/.213102454203392E+01/, * QD2/.116432601041188E+01/, QD3/.175509465791633E+00/, * QD4/.528319849831061E-02/, QD5/.867802002275824E-05/ C----------------------------------------------------------------------- IF (X .GT. 2.0) GO TO 10 Z = X - 1.0 R = ((((((AN6*Z + AN5)*Z + AN4)*Z + AN3)*Z + AN2)*Z * + AN1)*Z + AN0) / * (((((AD5*Z + AD4)*Z + AD3)*Z + AD2)*Z + AD1)*Z + AD0) PHI = ((((((BN6*Z + BN5)*Z + BN4)*Z + BN3)*Z + BN2)*Z * + BN1)*Z + BN0) / * ((((((BD6*Z + BD5)*Z + BD4)*Z + BD3)*Z + BD2)*Z * + BD1)*Z + BD0) GO TO 40 C 10 IF (X .GE. 4.0) GO TO 20 Z = X - 2.0 R = (((((CN5*Z + CN4)*Z + CN3)*Z + CN2)*Z + CN1)*Z + CN0) / * ((((((CD6*Z + CD5)*Z + CD4)*Z + CD3)*Z + CD2)*Z * + CD1)*Z + CD0) PHI = (((((DN5*Z + DN4)*Z + DN3)*Z + DN2)*Z + DN1)*Z + DN0) / * ((((((DD6*Z + DD5)*Z + DD4)*Z + DD3)*Z + DD2)*Z * + DD1)*Z + DD0) GO TO 40 C 20 IF (X .GT. 1.E10) GO TO 30 Z = 64.0/X**3 R = (((((PN5*Z + PN4)*Z + PN3)*Z + PN2)*Z + PN1)*Z + PN0) / * (((((PD5*Z + PD4)*Z + PD3)*Z + PD2)*Z + PD1)*Z + PD0) PHI = ((((QN4*Z + QN3)*Z + QN2)*Z + QN1)*Z + QN0) / * (((((QD5*Z + QD4)*Z + QD3)*Z + QD2)*Z + QD1)*Z + QD0) GO TO 40 C 30 R = PN0 PHI = QN0 C 40 RTX = SQRT(X) R = SQRT(R/RTX) PHI = PI4 + X*RTX*PHI RETURN END COMPLEX FUNCTION CK(K,L) C ------------------------------------------------------------------ C THIS FUNCTION CALCULATES THE COMPLETE ELLIPTIC INTEGRAL F(K) C FOR COMPLEX VALUES OF THE MODULUS K. IT IS ASSUMED THAT L.NE.0 C AND THAT K**2 + L**2 = 1. C ------------------------------------------------------------------ COMPLEX K,L,AK,AL,AK1,AL1,AL2,CKK,CKP,F1,F2,F3,FXK,AKTEMP,CK1,J COMPLEX CFLECT,KM,Z REAL LN4,X1(12),X2(12),W1(12),W2(12),FL(12),FA(12),FB(12) LOGICAL BRANCH C -------------------------------------------------------------- DATA X1(1)/ 6.5487222790801E-03/, X1(2)/ 3.8946809560450E-02/, 1 X1(3)/ 9.8150263106007E-02/, X1(4)/ 1.8113858159063E-01/, 2 X1(5)/ 2.8322006766737E-01/, X1(6)/ 3.9843443516344E-01/, 3 X1(7)/ 5.1995262679235E-01/, X1(8)/ 6.4051091671611E-01/, 4 X1(9)/ 7.5286501205183E-01/, X1(10)/8.5024002416230E-01/, 5 X1(11)/9.2674968322391E-01/, X1(12)/9.7775612969000E-01/ C -------------------------------------------------------------- DATA W1(1)/ 9.3192691443932E-02/, W1(2)/ 1.4975182757632E-01/, 1 W1(3)/ 1.6655745436459E-01/, W1(4)/ 1.5963355943699E-01/, 2 W1(5)/ 1.3842483186484E-01/, W1(6)/ 1.1001657063572E-01/, 3 W1(7)/ 7.9961821770829E-02/, W1(8)/ 5.2406954824642E-02/, 4 W1(9)/ 3.0071088873761E-02/, W1(10)/1.4249245587998E-02/, 5 W1(11)/4.8999245823217E-03/, W1(12)/8.3402903805690E-04/ C -------------------------------------------------------------- DATA FL(1)/ 1.5708005371203E+00/, FL(2)/ 1.5709452753591E+00/, 1 FL(3)/ 1.5717433742881E+00/, FL(4)/ 1.5740325056162E+00/, 2 FL(5)/ 1.5787613653341E+00/, FL(6)/ 1.5867393901613E+00/, 3 FL(7)/ 1.5983969635617E+00/, FL(8)/ 1.6135762587884E+00/, 4 FL(9)/ 1.6313677113831E+00/, FL(10)/1.6500349733510E+00/, 5 FL(11)/1.6671202200919E+00/, FL(12)/1.6798403417359E+00/ C -------------------------------------------------------------- DATA X2(1)/-9.8156063424672E-01/, X2(2)/-9.0411725637048E-01/, 1 X2(3)/-7.6990267419431E-01/, X2(4)/-5.8731795428662E-01/, 2 X2(5)/-3.6783149899818E-01/, X2(6)/-1.2523340851147E-01/, 3 X2(7)/ 1.2523340851147E-01/, X2(8)/ 3.6783149899818E-01/, 4 X2(9)/ 5.8731795428662E-01/, X2(10)/7.6990267419431E-01/, 5 X2(11)/9.0411725637048E-01/, X2(12)/9.8156063424672E-01/ C -------------------------------------------------------------- DATA W2(1)/ 4.7175336386512E-02/, W2(2)/ 1.0693932599532E-01/, 1 W2(3)/ 1.6007832854335E-01/, W2(4)/ 2.0316742672307E-01/, 2 W2(5)/ 2.3349253653836E-01/, W2(6)/ 2.4914704581340E-01/, 3 W2(7)/ 2.4914704581340E-01/, W2(8)/ 2.3349253653836E-01/, 4 W2(9)/ 2.0316742672307E-01/, W2(10)/1.6007832854335E-01/, 5 W2(11)/1.0693932599532E-01/, W2(12)/4.7175336386512E-02/ C -------------------------------------------------------------- DATA FA(1)/ 2.0794472764428E+00/, FA(2)/ 2.0795966441739E+00/, 1 FA(3)/ 2.0803359313463E+00/, FA(4)/ 2.0823286205438E+00/, 2 FA(5)/ 2.0862633195105E+00/, FA(6)/ 2.0926508621232E+00/, 3 FA(7)/ 2.1016440761258E+00/, FA(8)/ 2.1128974786197E+00/, 4 FA(9)/ 2.1254857173540E+00/, FA(10)/2.1379218133017E+00/, 5 FA(11)/2.1483404506064E+00/, FA(12)/2.1548934173960E+00/ C -------------------------------------------------------------- DATA FB(1)/ 1.5744273529551E+00/, FB(2)/ 1.5899097325063E+00/, 1 FB(3)/ 1.6176685384410E+00/, FB(4)/ 1.6574605448620E+00/, 2 FB(5)/ 1.7087245795822E+00/, FB(6)/ 1.7703459462057E+00/, 3 FB(7)/ 1.8403280188791E+00/, FB(8)/ 1.9154060277115E+00/, 4 FB(9)/ 1.9907093877047E+00/, FB(10)/2.0596975322636E+00/, 5 FB(11)/2.1146977530430E+00/, FB(12)/2.1482986855683E+00/ C -------------------------------------------------------------- DATA J/(0.0, 1.0)/ DATA LN4 /1.3862943611199/ DATA C1 /.20264236728467/, C2/.15915494309189/ C --------------------------------------------------- C C EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE C SMALLEST NUMBER SUCH THAT 1. + EPS .GT. 1. C EPS = SPMPAR(1) C C --------------------------------------------------- IF (L .EQ. (0.0, 0.0)) GO TO 200 IND = 0 BRANCH = .TRUE. TOL = 8.0*AMAX1(EPS, 1.E-14) C AK1 = CFLECT(K) AL1 = CFLECT(L) AK = AK1 AL = AL1 C X = REAL(AK) Y = AIMAG(AK) U = REAL(AL) V = AIMAG(AL) IF (AMAX1(X,ABS(Y)) .GE. 1.0/EPS) GO TO 90 IF (AMAX1(U,ABS(V)) .GE. 1.1/EPS) GO TO 200 C C CHECK THAT K**2 + L**2 = 1 C IF (X .LT. U) GO TO 1 T = U/X IF (ABS(X*X/(V*V + 1.0/(1.0 + T*T)) - 1.0) .GT. TOL) GO TO 200 IF (ABS(Y + T*V) .GT. TOL*AMAX1(1.0, ABS(V))) GO TO 200 GO TO 10 1 T = X/U IF (ABS(U*U/(Y*Y + 1.0/(1.0 + T*T)) - 1.0) .GT. TOL) GO TO 200 IF (ABS(V + T*Y) .GT. TOL*AMAX1(1.0, ABS(Y))) GO TO 200 C C USES LOGARITHMIC SERIES WHEN CABS(AL) C IS LESS THAN OR EQUAL TO 0.55 C 10 IF (U .GT. 1.42 .OR. ABS(V) .GT. 1.42) GO TO 50 11 IF (CABS(AL) .GT. 0.55) GO TO 20 CALL KL(AL,CKK,CKP) IF (BRANCH) GO TO 22 CK1 = CKK CK = CKP AL = AK GO TO 80 C C USES MACLAURIN EXPANSION WHEN THE ABSOLUTE VALUE OF C THE MODULUS AK IS LESS THAN OR EQUAL TO 0.55 C 20 R = CABS(AK) IF (R .GT. 0.55) GO TO 30 IF (BRANCH) GO TO 21 CALL KL(AK,CKP,CK1) CK = CKP AL = AK GO TO 80 21 CKK = KM(AK*AK) 22 CK = CKK GO TO 70 C C NUMERICAL QUADRATURE APPROXIMATION C 30 IF (IND .EQ. 0 .AND. R .GT. 1.0) GO TO 50 31 AL2 = AL*AL C F1 = (0.0, 0.0) DO 40 I = 1,12 XX = X1(I)/2. FXK = AK*XX 40 F1 = F1 + W1(I)*FL(I)/(AL2 + FXK*FXK) F2 = (0.0, 0.0) DO 41 I = 1,12 XX = .25*(1.+ X2(I)) FXK = AK*XX 41 F2 = F2 + W2(I)*FA(I)/(AL2 + FXK*FXK) F3 = (0.0, 0.0) DO 42 I = 1,12 XX = .25*(3.- X2(I)) FXK = AK*XX 42 F3 = F3 + W2(I)*FB(I)/(AL2 + FXK*FXK) C CK = AL*(C1*F1 + C2*(F2 + F3)) C C END OF NUMERICAL QUADRATURE APPROXIMATION C IF (BRANCH) GO TO 70 CK1 = CK BRANCH = .TRUE. C C INTERCHANGE AK AND AL C AKTEMP = AK AK = AL AL = AKTEMP GO TO 31 C C USES INVERSE MODULUS TRANSFORMATION WHEN CABS(AK) IS GREATER C THAN 1 AND REAL(AK**2) IS GREATER THAN 0.5. C 50 IF (X*X .LE. Y*Y + 0.5) GO TO 60 IND = 1 BRANCH = .FALSE. AK = 1.0/AK1 AL = CFLECT(J*AL1/AK1) GO TO 11 C C USES COMPLEMENTARY INVERSE MODULUS TRANSFORMATION WHEN CABS(AK) C IS GREATER THAN 1 AND REAL(AK**2) IS LESS THAN OR EQUAL TO 0.5 C 60 IND = 2 AK = CFLECT(J*AK1/AL1) AL = 1.0/AL1 GO TO 11 C C RETURN IF NO TRANSFORMATIONS HAVE BEEN PERFORMED C 70 IF (IND .EQ. 0) RETURN IF (IND .EQ. 1) GO TO 80 C C COMPLEMENTARY INVERSE MODULUS TRANSFORMATION C CK = AL*CK RETURN C C INVERSE MODULUS TRANSFORMATION C 80 IF (AIMAG(AK1) .GE. 0.0) GO TO 81 CK = AL*(CK1 - J*CK) RETURN 81 CK = AL*(CK1 + J*CK) RETURN C C CALCULATION OF F(K) FOR LARGE K AND L C 90 IF (X .LE. ABS(Y)) GO TO 100 IF (ABS(ABS(V/X) - 1.0) .GT. TOL) GO TO 200 IF (ABS(U/X + Y/V) .GT. TOL) GO TO 200 T = Y/X PHI = ATAN2(X,ABS(Y)) R = (LN4 + 0.5*ALNREL(T*T)) + ALOG(X) IF (Y .LT. 0.0) R = -R CK = (CMPLX(PHI,R)/CMPLX(1.0,T))/X RETURN C 100 IF (ABS(ABS(U/Y) - 1.0) .GT. TOL) GO TO 200 IF (ABS(X/U + V/Y) .GT. TOL) GO TO 200 T = V/U Z = CMPLX((LN4 + 0.5*ALNREL(T*T)) + ALOG(U), ATAN2(V,U)) CK = (Z/CMPLX(1.0,T))/U RETURN C C ERROR RETURN C 200 CK = (0.0, 0.0) RETURN END COMPLEX FUNCTION CFLECT(Z) C--------------------------------------------------------- C REFLECTS Z WITH RESPECT TO THE ORIGIN IF REAL(Z) C .LT. 0.0 OR IF Z IS ON THE NEGATIVE IMAGINARY AXIS. C--------------------------------------------------------- COMPLEX Z C ---------- IF (REAL(Z)) 10,20,30 10 CFLECT = -Z RETURN 20 CFLECT = CMPLX(0.0, ABS(AIMAG(Z))) RETURN 30 CFLECT = Z RETURN END COMPLEX FUNCTION KM(K2) COMPLEX K2 C--------------------------------------------------------------------- C KM COMPUTES THE COMPLETE ELLIPTIC INTEGRAL F(K) FOR A GIVEN C VALUE OF K2 = K**2 BY USE OF THE MACLAURIN EXPANSION. C--------------------------------------------------------------------- COMPLEX AN,S1 DATA HPI /1.5707963267949/ C --------------- C C ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE C SMALLEST NUMBER SUCH THAT 1 + EPS .GT. 1. C EPS = SPMPAR(1) C C --------------- C TOL = AMAX1(EPS,1.E-14) S1 = (1.0, 0.0) AN = (1.0, 0.0) DO 10 I = 1,50 RI = I C = ((RI - 0.5)/RI)**2 AN = C*(AN*K2) S1 = S1 + AN IF (ABS(REAL(AN)) + ABS(AIMAG(AN)) .LT. TOL) GO TO 20 10 CONTINUE C 20 KM = HPI*S1 RETURN END SUBROUTINE KL (L, FK, FL) COMPLEX L, FK, FL C ---------------------------------------------------------------------- C KL COMPUTES THE COMPLETE ELLIPTIC INTEGRALS F(K) AND F(L) FOR C A GIVEN VALUE OF L, WHERE CABS(L) .LT. 1 AND K**2 + L**2 = 1. C IT IS ASSUMED THAT -PI .LE. ARG(L**2) .LT. PI FOR THE RESULTING C VALUE FOR F(K) TO BE MEANINGFUL. C ---------------------------------------------------------------------- COMPLEX AN,L2,S1,S2,W REAL LN4 C -------------- DATA HPI /1.5707963267949/ DATA LN4 /1.3862943611199/ C --------------- C C ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE C SMALLEST NUMBER SUCH THAT 1 + EPS .GT. 1. C EPS = SPMPAR(1) C C --------------- C C THE LOGARITHMIC EXPANSION IS USED FOR F(K) C AND THE MACLAURIN EXPANSION FOR F(L) C TOL = AMAX1(EPS,1.E-14) L2 = L*L S1 = (0.0, 0.0) S2 = (0.0, 0.0) AN = (1.0, 0.0) BN = 0.0 DO 10 I = 1,50 RI = I C = ((RI - 0.5)/RI)**2 AN = C*(AN*L2) BN = BN + 1.0/(RI*(2.0*RI - 1.0)) S1 = S1 + AN S2 = S2 + AN*BN IF (ABS(REAL(AN)) + ABS(AIMAG(AN)) .LT. TOL) GO TO 20 10 CONTINUE 20 S1 = S1 + (1.0, 0.0) C C SET W = 0.5*CLOG(16.0/L2) C X = REAL(L) Y = AIMAG(L) IF (X .NE. 0.0) GO TO 30 W = CMPLX(LN4 - ALOG(ABS(Y)), HPI) GO TO 50 C 30 IF (ABS(X) .GT. ABS(Y)) GO TO 31 U = (LN4 - 0.5*ALNREL((X/Y)**2)) - ALOG(ABS(Y)) GO TO 40 31 U = (LN4 - 0.5*ALNREL((Y/X)**2)) - ALOG(ABS(X)) C 40 IF (X .GT. 0.0) GO TO 41 W = CMPLX(U, -ATAN2(-Y,-X)) GO TO 50 41 W = CMPLX(U, -ATAN2(Y,X)) C C FINAL ASSEMBLY C 50 FK = W*S1 - S2 FL = HPI*S1 RETURN END SUBROUTINE CKE(K,L,CK,CE,IERR) C ------------------------------------------------------------------ C THIS FUNCTION CALCULATES THE COMPLETE ELLIPTIC INTEGRALS F(K) C AND E(K) FOR COMPLEX VALUES OF THE MODULUS K. IT IS ASSUMED C THAT L.NE.0 AND THAT K**2 + L**2 = 1. C ------------------------------------------------------------------ COMPLEX K,L,AK,AL,AK1,AL1,CKK,CKP,F1,F2,F3,AKTEMP,CK1,J COMPLEX CE,CK,CEE,CEP,CE1,E1,E2,E3,AT,FX,FXK,ATN COMPLEX CFLECT,K1,L1,AK2,AL2,Z,G,G1,GG,GP REAL LN4,X1(12),X2(12),W1(12),W2(12),FL(12),FA(12),FB(12) LOGICAL BRANCH C -------------------------------------------------------------- DATA X1(1)/ 6.5487222790801E-03/, X1(2)/ 3.8946809560450E-02/, 1 X1(3)/ 9.8150263106007E-02/, X1(4)/ 1.8113858159063E-01/, 2 X1(5)/ 2.8322006766737E-01/, X1(6)/ 3.9843443516344E-01/, 3 X1(7)/ 5.1995262679235E-01/, X1(8)/ 6.4051091671611E-01/, 4 X1(9)/ 7.5286501205183E-01/, X1(10)/8.5024002416230E-01/, 5 X1(11)/9.2674968322391E-01/, X1(12)/9.7775612969000E-01/ C -------------------------------------------------------------- DATA W1(1)/ 9.3192691443932E-02/, W1(2)/ 1.4975182757632E-01/, 1 W1(3)/ 1.6655745436459E-01/, W1(4)/ 1.5963355943699E-01/, 2 W1(5)/ 1.3842483186484E-01/, W1(6)/ 1.1001657063572E-01/, 3 W1(7)/ 7.9961821770829E-02/, W1(8)/ 5.2406954824642E-02/, 4 W1(9)/ 3.0071088873761E-02/, W1(10)/1.4249245587998E-02/, 5 W1(11)/4.8999245823217E-03/, W1(12)/8.3402903805690E-04/ C -------------------------------------------------------------- DATA FL(1)/ 1.5708005371203E+00/, FL(2)/ 1.5709452753591E+00/, 1 FL(3)/ 1.5717433742881E+00/, FL(4)/ 1.5740325056162E+00/, 2 FL(5)/ 1.5787613653341E+00/, FL(6)/ 1.5867393901613E+00/, 3 FL(7)/ 1.5983969635617E+00/, FL(8)/ 1.6135762587884E+00/, 4 FL(9)/ 1.6313677113831E+00/, FL(10)/1.6500349733510E+00/, 5 FL(11)/1.6671202200919E+00/, FL(12)/1.6798403417359E+00/ C -------------------------------------------------------------- DATA X2(1)/-9.8156063424672E-01/, X2(2)/-9.0411725637048E-01/, 1 X2(3)/-7.6990267419431E-01/, X2(4)/-5.8731795428662E-01/, 2 X2(5)/-3.6783149899818E-01/, X2(6)/-1.2523340851147E-01/, 3 X2(7)/ 1.2523340851147E-01/, X2(8)/ 3.6783149899818E-01/, 4 X2(9)/ 5.8731795428662E-01/, X2(10)/7.6990267419431E-01/, 5 X2(11)/9.0411725637048E-01/, X2(12)/9.8156063424672E-01/ C -------------------------------------------------------------- DATA W2(1)/ 4.7175336386512E-02/, W2(2)/ 1.0693932599532E-01/, 1 W2(3)/ 1.6007832854335E-01/, W2(4)/ 2.0316742672307E-01/, 2 W2(5)/ 2.3349253653836E-01/, W2(6)/ 2.4914704581340E-01/, 3 W2(7)/ 2.4914704581340E-01/, W2(8)/ 2.3349253653836E-01/, 4 W2(9)/ 2.0316742672307E-01/, W2(10)/1.6007832854335E-01/, 5 W2(11)/1.0693932599532E-01/, W2(12)/4.7175336386512E-02/ C -------------------------------------------------------------- DATA FA(1)/ 2.0794472764428E+00/, FA(2)/ 2.0795966441739E+00/, 1 FA(3)/ 2.0803359313463E+00/, FA(4)/ 2.0823286205438E+00/, 2 FA(5)/ 2.0862633195105E+00/, FA(6)/ 2.0926508621232E+00/, 3 FA(7)/ 2.1016440761258E+00/, FA(8)/ 2.1128974786197E+00/, 4 FA(9)/ 2.1254857173540E+00/, FA(10)/2.1379218133017E+00/, 5 FA(11)/2.1483404506064E+00/, FA(12)/2.1548934173960E+00/ C -------------------------------------------------------------- DATA FB(1)/ 1.5744273529551E+00/, FB(2)/ 1.5899097325063E+00/, 1 FB(3)/ 1.6176685384410E+00/, FB(4)/ 1.6574605448620E+00/, 2 FB(5)/ 1.7087245795822E+00/, FB(6)/ 1.7703459462057E+00/, 3 FB(7)/ 1.8403280188791E+00/, FB(8)/ 1.9154060277115E+00/, 4 FB(9)/ 1.9907093877047E+00/, FB(10)/2.0596975322636E+00/, 5 FB(11)/2.1146977530430E+00/, FB(12)/2.1482986855683E+00/ C -------------------------------------------------------------- DATA J/(0.0, 1.0)/ DATA LN4 /1.3862943611199/ DATA C1 /.20264236728467/, C2/.15915494309189/ C --------------------------------------------------- C C EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE C SMALLEST NUMBER SUCH THAT 1. + EPS .GT. 1. C EPS = SPMPAR(1) C C --------------------------------------------------- IF (L .EQ. (0.0, 0.0)) GO TO 200 IND = 0 BRANCH = .TRUE. TOL = 8.0*AMAX1(EPS, 1.E-14) C AK1 = CFLECT(K) AL1 = CFLECT(L) AK = AK1 AL = AL1 IERR = 0 C X = REAL(AK) Y = AIMAG(AK) U = REAL(AL) V = AIMAG(AL) IF (AMAX1(X,ABS(Y)) .GE. 1.0/EPS) GO TO 90 IF (AMAX1(U,ABS(V)) .GE. 1.1/EPS) GO TO 210 C C CHECK THAT K**2 + L**2 = 1 C IF (X .LT. U) GO TO 1 T = U/X IF (ABS(X*X/(V*V + 1.0/(1.0 + T*T)) - 1.0) .GT. TOL) GO TO 210 IF (ABS(Y + T*V) .GT. TOL*AMAX1(1.0, ABS(V))) GO TO 210 GO TO 10 1 T = X/U IF (ABS(U*U/(Y*Y + 1.0/(1.0 + T*T)) - 1.0) .GT. TOL) GO TO 210 IF (ABS(V + T*Y) .GT. TOL*AMAX1(1.0, ABS(Y))) GO TO 210 C C USES LOGARITHMIC SERIES WHEN CABS(AL) C IS LESS THAN OR EQUAL TO 0.55 C 10 IF (U .GT. 1.42 .OR. ABS(V) .GT. 1.42) GO TO 50 11 IF (CABS(AL) .GT. 0.55) GO TO 20 CALL EKL(AL,CKK,CKP,CEE,CEP,GG,GP) IF (BRANCH) GO TO 22 CK1 = CKK CK = CKP CE1 = CEE CE = CEP G1 = GG G = GP AK2 = AL*AL AL = AK AL2 = AL*AL GO TO 81 C C USES MACLAURIN EXPANSION WHEN THE ABSOLUTE VALUE OF C THE MODULUS AK IS LESS THAN OR EQUAL TO 0.55 C 20 R = CABS(AK) IF (R .GT. 0.55) GO TO 30 IF (BRANCH) GO TO 21 CALL EKL(AK,CKP,CK1,CEP,CE1,GP,G1) CK = CKP CE = CEP G = GP AK2 = AL*AL AL = AK AL2 = AL*AL GO TO 81 21 CALL EKM(AK*AK,CKK,CEE) 22 CK = CKK CE = CEE GO TO 70 C C NUMERICAL QUADRATURE APPROXIMATION C 30 IF (IND .EQ. 0 .AND. R .GT. 1.0) GO TO 50 31 AL2 = AL*AL AK2 = AK*AK C F1 = (0.0, 0.0) E1 = (0.0, 0.0) DO 40 I = 1,12 XX = X1(I)/2. FX = AK*XX/AL FXK = AK*XX AT = ATN(FX) E1 = E1 + W1(I)*FL(I)*(1.0 + AT) 40 F1 = F1 + W1(I)*FL(I)/(AL2 + FXK*FXK) F2 = (0.0, 0.0) E2 = (0.0, 0.0) DO 41 I = 1,12 XX = .25*(1.+ X2(I)) FX = AK*XX/AL FXK = AK*XX AT = ATN(FX) E2 = E2 + W2(I)*FA(I)*(1.0 + AT) 41 F2 = F2 + W2(I)*FA(I)/(AL2 + FXK*FXK) F3 = (0.0, 0.0) E3 = (0.0, 0.0) DO 42 I = 1,12 XX = .25*(3.- X2(I)) FX = AK*XX/AL FXK = AK*XX AT = ATN(FX) E3 = E3 + W2(I)*FB(I)*(1.0 + AT) 42 F3 = F3 + W2(I)*FB(I)/(AL2 + FXK*FXK) C CK = AL*(C1*F1 + C2*(F2 + F3)) CE = AL*(C1*E1 + C2*(E2 + E3)) C C END OF NUMERICAL QUADRATURE APPROXIMATION C IF (BRANCH) GO TO 70 CK1 = CK CE1 = CE BRANCH = .TRUE. C C INTERCHANGE AK AND AL C AKTEMP = AK AK = AL AL = AKTEMP GO TO 31 C C USES INVERSE MODULUS TRANSFORMATION WHEN CABS(AK) IS GREATER C THAN 1 AND REAL(AK**2) IS GREATER THAN 0.5. C 50 IF (X*X .LE. Y*Y + 0.5) GO TO 60 IND = 1 BRANCH = .FALSE. AK = 1.0/AK1 AL = CFLECT(J*AL1/AK1) GO TO 11 C C USES COMPLEMENTARY INVERSE MODULUS TRANSFORMATION WHEN CABS(AK) C IS GREATER THAN 1 AND REAL(AK**2) IS LESS THAN OR EQUAL TO 0.5 C 60 IND = 2 AK = CFLECT(J*AK1/AL1) AL = 1.0/AL1 GO TO 11 C C RETURN IF NO TRANSFORMATIONS HAVE BEEN PERFORMED C 70 IF (IND .EQ. 0) RETURN IF (IND .EQ. 1) GO TO 80 C C COMPLEMENTARY INVERSE MODULUS TRANSFORMATION C CK = AL*CK CE = CE/AL RETURN C C INVERSE MODULUS TRANSFORMATION C 80 G = CE - AL2*CK G1 = CE1 - AK2*CK1 81 IF (AIMAG(AK2) .GE. 0.0) GO TO 82 CE = (G1 + J*G)/AL CK = AL*(CK1 - J*CK) RETURN 82 CE = (G1 - J*G)/AL CK = AL*(CK1 + J*CK) RETURN C C CALCULATION OF F(K) AND E(K) FOR LARGE K AND L C 90 IF (X .LE. ABS(Y)) GO TO 100 IF (ABS(ABS(V/X) - 1.0) .GT. TOL) GO TO 210 IF (ABS(U/X + Y/V) .GT. TOL) GO TO 210 T = Y/X K1 = CMPLX(1.0,T) PHI = ATAN2(X,ABS(Y)) R = (LN4 + 0.5*ALNREL(T*T)) + ALOG(X) C = 0.5*R + 0.25 Z = CMPLX(Y,-X) IF (Y .GE. 0.0) GO TO 91 R = -R C = -C Z = -Z 91 CK = (CMPLX(PHI,R)/K1)/X CE = Z + (CMPLX(0.5*PHI,C)/K1)/X RETURN C 100 IF (ABS(ABS(U/Y) - 1.0) .GT. TOL) GO TO 210 IF (ABS(X/U + V/Y) .GT. TOL) GO TO 210 T = V/U L1 = CMPLX(1.0,T) R = (LN4 + 0.5*ALNREL(T*T)) + ALOG(U) PHI = ATAN2(V,U) CK = (CMPLX(R, PHI)/L1)/U CE = AL + (CMPLX(0.5*R - 0.25, 0.5*PHI)/L1)/U RETURN C C ERROR RETURN C 200 IERR = 1 RETURN 210 IERR = 2 RETURN END COMPLEX FUNCTION ATN(Z) C--------------------------------------------------- C CALCULATES COMPLEX FUNCTION ATN(Z) = Z*ATAN(Z) C USING DOUBLE PRECISION. C--------------------------------------------------- COMPLEX Z DOUBLE PRECISION DX, DY X = REAL(Z) Y = AIMAG(Z) DX = X DY = Y T = 1.D0 - DX*DX - DY*DY DA = -0.5*ATAN2(-2.0*X, T) D = (1.0 - DY)**2 + DX*DX DB = 0.25*ALNREL(4.0*Y/D) ATN1 = DA*X - DB*Y ATN2 = DA*Y + DB*X ATN = CMPLX(ATN1, ATN2) RETURN END SUBROUTINE EKM (K2, FK, EK) COMPLEX K2,FK,EK C ---------------------------------------------------------------------- C EKM COMPUTES THE COMPLETE ELLIPTIC INTEGRALS F(K) AND E(K) FOR C A GIVEN VALUE OF K2 = K**2 BY USE OF THE MACLAURIN EXPANSIONS. C ---------------------------------------------------------------------- COMPLEX AN,CN,S1,S2 DATA HPI /1.5707963267949/ C --------------- C C ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE C SMALLEST NUMBER SUCH THAT 1 + EPS .GT. 1. C EPS = SPMPAR(1) C C --------------- C TOL = AMAX1(EPS,1.E-14) S1 = (1.0, 0.0) S2 = (1.0, 0.0) AN = (1.0, 0.0) DO 10 I = 1,50 RI = I C = ((RI - 0.5)/RI)**2 AN = C*(AN*K2) CN = AN/(2.0*RI - 1.0) S1 = S1 + AN S2 = S2 - CN IF (ABS(REAL(AN)) + ABS(AIMAG(AN)) .LT. TOL) GO TO 20 10 CONTINUE C 20 FK = HPI*S1 EK = HPI*S2 RETURN END SUBROUTINE EKL (L,FK,FL,EK,EL,GK,GL) COMPLEX L,L2,FK,FL,EK,EL,GK,GL C ---------------------------------------------------------------------- C EKL COMPUTES THE COMPLETE ELLIPTIC INTEGRALS F(K), F(L), E(K), C E(L) FOR A GIVEN VALUE OF L2, WHERE L2 = L**2 AND K**2 + L**2 = 1. C IT IS ASSUMED THAT -PI .LT. ARG(L2) .LE. PI FOR THE RESULTING C VALUE FOR F(K) TO BE MEANINGFUL. THE COMBINATIONS OF FUNCTIONS C G(K) = E(K) - L**2*F(K) AND G(L) = E(L) - K**2*F(L) ARE ALSO C CALCULATED. C ---------------------------------------------------------------------- COMPLEX AN,CN,EN,S1,S2,S3,S4,S5,S6,S7,W REAL LN4 C ------------------ DATA HPI /1.5707963267949/ DATA LN4 /1.3862943611199/ C --------------- C C ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE C SMALLEST NUMBER SUCH THAT 1 + EPS .GT. 1. C EPS = SPMPAR(1) C C --------------- C C THE LOGARITHMIC EXPANSIONS ARE USED FOR F(K) AND E(K) C AND THE MACLAURIN EXPANSIONS FOR F(L) AND E(L) C TOL = AMAX1(EPS,1.E-14) L2 = L*L S1 = (0.0, 0.0) S2 = (0.0, 0.0) S3 = (0.0, 0.0) S4 = (0.0, 0.0) S5 = (0.0, 0.0) S6 = (0.0, 0.0) S7 = (0.0, 0.0) AN = (1.0, 0.0) BN = 0.0 DO 10 I = 1,300 RI = I C = ((RI - 0.5)/RI)**2 AN = C*(AN*L2) BN = BN + 1.0/(RI*(2.0*RI - 1.0)) CN = AN/(2.0*RI - 1.0) DN = BN*RI/(RI - 0.5) EN = CN/(2.0*RI - 1.0) FN = RI/(RI - 0.5) GN = 0.5/(RI + 1.0) S1 = S1 + AN S2 = S2 + AN*BN S3 = S3 - CN S4 = S4 + AN*DN S5 = S5 + EN S6 = S6 + AN*FN S7 = S7 + AN*GN IF (ABS(REAL(AN)) + ABS(AIMAG(AN)) .LT. TOL) GO TO 20 10 CONTINUE 20 S1 = S1 + (1.0, 0.0) S3 = S3 + (1.0, 0.0) S5 = S5 + (1.0, 0.0) S7 = S7 + (0.5, 0.0) C C SET W = 0.5*CLOG(16.0/L2) C X = REAL(L) Y = AIMAG(L) IF (X .NE. 0.0) GO TO 30 W = CMPLX(LN4 - ALOG(ABS(Y)), HPI) GO TO 50 C 30 IF (ABS(X) .GT. ABS(Y)) GO TO 31 U = (LN4 - 0.5*ALNREL((X/Y)**2)) - ALOG(ABS(Y)) GO TO 40 31 U = (LN4 - 0.5*ALNREL((Y/X)**2)) - ALOG(ABS(X)) C 40 IF (X .GT. 0.0) GO TO 41 W = CMPLX(U, -ATAN2(-Y,-X)) GO TO 50 41 W = CMPLX(U, -ATAN2(Y,X)) C C FINAL ASSEMBLY C 50 FK = W*S1 - S2 FL = HPI*S1 EK = W*S6 - S4 + S5 EL = HPI*S3 GK = -W*S7*L2 -S4 + S5 + S2*L2 GL = HPI*S7*L2 RETURN END SUBROUTINE ELLPI (PHI, CPHI, K, L, F, E, IERR) C----------------------------------------------------------------------- C C REAL ELLIPTIC INTEGRALS OF THE FIRST AND SECOND KINDS C C ----------------- C C PHI = ARGUMENT (0.0 .LE. PHI .LE. PI/2) C CPHI = PI/2 - PHI (0.0 .LE. CPHI .LE. PI/2) C K = MODULUS (ABS(K) .LE. 1.0) C L = COMODULUS = SQRT (1 - K*K) (ABS(L) .LE. 1.0) C F = ELLIPTIC INTEGRAL OF FIRST KIND = F(PHI, K) C E = ELLIPTIC INTEGRAL OF SECOND KIND = E(PHI, K) C IERR = ERROR INDICATOR (IERR = 0 IF NO ERRORS) C----------------------------------------------------------------------- REAL K, L, K2, L2, LN4 C------------------------ C LN4 = LN(4) C TH1 = TANH(1) C------------------------ DATA LN4/1.3862943611199/ DATA TH1/.76159415595576/ C------------------------ IF (PHI .LT. 0.0 .OR. CPHI .LT. 0.0) GO TO 100 IF (ABS(K) .GT. 1.0 .OR. ABS(L) .GT. 1.0) GO TO 110 IERR = 0 IF (PHI .NE. 0.0) GO TO 10 F = 0.0 E = 0.0 RETURN C 10 IF (PHI .LT. 0.79) GO TO 11 SN = COS(CPHI) CN = SIN(CPHI) GO TO 20 11 SN = SIN(PHI) CN = COS(PHI) C 20 K2 = K*K L2 = L*L SS = SN*SN PX = ABS(K*SN) QX = ABS(K*CN) IF (PX .GE. TH1) GO TO 50 C C SERIES EXPANSION FOR ABS(K*SIN(PHI)) .LE. TANH(1) C PN = 1.0 QN = 2.0 AN = PHI HN = 1.0 S1 = 0.0 S2 = 0.0 TR = PHI*SS TS = SN*CN C 30 AN = (PN*AN - TS)/QN R = K2*HN/QN S2 = S2 + R*AN HN = PN*R S0 = S1 S1 = S1 + HN*AN IF (ABS(TR) .LT. ABS(AN)) GO TO 40 IF (ABS(S1) .LE. ABS(S0)) GO TO 40 PN = QN + 1.0 QN = PN + 1.0 TR = SS*TR TS = SS*TS GO TO 30 C 40 F = PHI + S1 E = PHI - S2 RETURN C C SERIES EXPANSION FOR ABS(K*SIN(PHI)) .GT. TANH(1) C 50 R = CPABS(L,QX) IF (R .EQ. 0.0) GO TO 120 R2 = R*R SI = 1.0 SJ = 1.0 SK = 0.0 RM = 0.0 RN = 0.0 S1 = 0.0 S2 = 0.0 S3 = 0.0 S4 = 0.0 TD = QX*R DN = 2.0 GO TO 70 C 60 SI = RI SJ = RJ SK = RK DN = DN + 2.0 TD = R2*TD 70 PN = (DN - 1.0)/DN QN = (DN + 1.0)/(DN + 2.0) RI = PN*SI RJ = PN*PN*L2*SJ RK = SK + 2.0/(DN*(DN - 1.0)) R0 = TD/DN RM = QN*QN*L2*(RM - R0*RI) RN = PN*QN*L2*(RN - R0*SI) D1 = RJ D2 = QN*RJ D3 = RM - RJ*RK D4 = RN - PN*L2*SJ*RK + L2*SJ/(DN*DN) R0 = S3 S1 = S1 + D1 S2 = S2 + D2 S3 = S3 + D3 S4 = S4 + D4 IF (S3 .LT. R0) GO TO 60 C W = 1.0 + PX P = LN4 - ALOG(R + QX) T1 = (1.0 + S1)*P + QX/R*ALNREL(-0.5*R2/W) T2 = (0.5 + S2)*L2*P + (1.0 - QX*R/W) F = T1 + S3 E = T2 + S4 RETURN C C ERROR RETURN C 100 IERR = 1 RETURN 110 IERR = 2 RETURN 120 IERR = 3 RETURN END SUBROUTINE DELLPI (PHI, CPHI, K, L, F, E, IERR) C----------------------------------------------------------------------- C C DOUBLE PRECISION COMPUTATION OF THE C REAL ELLIPTIC INTEGRALS OF THE FIRST AND SECOND KINDS C C ----------------- C C PHI = ARGUMENT (0.0 .LE. PHI .LE. PI/2) C CPHI = PI/2 - PHI (0.0 .LE. CPHI .LE. PI/2) C K = MODULUS (DABS(K) .LE. 1.0) C L = COMODULUS = SQRT (1 - K*K) (DABS(L) .LE. 1.0) C F = ELLIPTIC INTEGRAL OF FIRST KIND = F(PHI, K) C E = ELLIPTIC INTEGRAL OF SECOND KIND = E(PHI, K) C IERR = ERROR INDICATOR (IERR = 0 IF NO ERRORS) C----------------------------------------------------------------------- DOUBLE PRECISION PHI, CPHI, K, L, F, E DOUBLE PRECISION AN, CN, DN, D1, D2, D3, D4, HN, K2, L2, LN4, * P, PN, PX, QN, QX, R, RI, RJ, RK, RM, RN, R0, * R2, SI, SJ, SK, SN, SS, S0, S1, S2, S3, S4, * TD, TH1, TR, TS, T1, T2, W DOUBLE PRECISION DLNREL, DCPABS C------------------------ C LN4 = LN(4) C TH1 = TANH(1) C------------------------ DATA LN4 /.1386294361119890618834464242916353136151D+01/ DATA TH1 /.7615941559557648881194582826047935904128D+00/ C------------------------ IF (PHI .LT. 0.D0 .OR. CPHI .LT. 0.D0) GO TO 100 IF (DABS(K) .GT. 1.D0 .OR. DABS(L) .GT. 1.D0) GO TO 110 IERR = 0 IF (PHI .NE. 0.D0) GO TO 10 F = 0.D0 E = 0.D0 RETURN C 10 IF (PHI .LT. 0.79D0) GO TO 11 SN = DCOS(CPHI) CN = DSIN(CPHI) GO TO 20 11 SN = DSIN(PHI) CN = DCOS(PHI) C 20 K2 = K*K L2 = L*L SS = SN*SN PX = DABS(K*SN) QX = DABS(K*CN) IF (PX .GE. TH1) GO TO 50 C C SERIES EXPANSION FOR ABS(K*SIN(PHI)) .LE. TANH(1) C PN = 1.D0 QN = 2.D0 AN = PHI HN = 1.D0 S1 = 0.D0 S2 = 0.D0 TR = PHI*SS TS = SN*CN C 30 AN = (PN*AN - TS)/QN R = K2*HN/QN S2 = S2 + R*AN HN = PN*R S0 = S1 S1 = S1 + HN*AN IF (DABS(TR) .LT. DABS(AN)) GO TO 40 IF (DABS(S1) .LE. DABS(S0)) GO TO 40 PN = QN + 1.D0 QN = PN + 1.D0 TR = SS*TR TS = SS*TS GO TO 30 C 40 F = PHI + S1 E = PHI - S2 RETURN C C SERIES EXPANSION FOR ABS(K*SIN(PHI)) .GT. TANH(1) C 50 R = DCPABS(L,QX) IF (R .EQ. 0.D0) GO TO 120 R2 = R*R SI = 1.D0 SJ = 1.D0 SK = 0.D0 RM = 0.D0 RN = 0.D0 S1 = 0.D0 S2 = 0.D0 S3 = 0.D0 S4 = 0.D0 TD = QX*R DN = 2.D0 GO TO 70 C 60 SI = RI SJ = RJ SK = RK DN = DN + 2.D0 TD = R2*TD 70 PN = (DN - 1.D0)/DN QN = (DN + 1.D0)/(DN + 2.D0) RI = PN*SI RJ = PN*PN*L2*SJ RK = SK + 2.D0/(DN*(DN - 1.D0)) R0 = TD/DN RM = QN*QN*L2*(RM - R0*RI) RN = PN*QN*L2*(RN - R0*SI) D1 = RJ D2 = QN*RJ D3 = RM - RJ*RK D4 = RN - PN*L2*SJ*RK + L2*SJ/(DN*DN) R0 = S3 S1 = S1 + D1 S2 = S2 + D2 S3 = S3 + D3 S4 = S4 + D4 IF (S3 .LT. R0) GO TO 60 C W = 1.D0 + PX P = LN4 - DLOG(R + QX) T1 = (1.D0 + S1)*P + QX/R*DLNREL(-0.5D0*R2/W) T2 = (0.5D0 + S2)*L2*P + (1.D0 - QX*R/W) F = T1 + S3 E = T2 + S4 RETURN C C ERROR RETURN C 100 IERR = 1 RETURN 110 IERR = 2 RETURN 120 IERR = 3 RETURN END SUBROUTINE EPI (PHI, CPHI, K2, L2, N, M, P, IERR) C----------------------------------------------------------------------- C REAL ELLIPTIC INTEGRAL OF THE THIRD KIND C----------------------------------------------------------------------- REAL PHI, CPHI, K2, L2, N, M, P REAL A, B, C, EPS, PIHALF, R, RF, S, S2, TOL REAL SPMPAR C--------------------- DATA PIHALF /1.5707963267948966192/ C----------------------------------------------------------------------- C C ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE C SMALLEST NUMBER SUCH THAT 1.0 + EPS .GT. 1.0. C EPS = SPMPAR(1) C C----------------------------------------------------------------------- TOL = 4.0 * EPS IF (AMIN1(PHI,CPHI) .LT. 0.0) GO TO 100 IF (ABS((PHI + CPHI) - PIHALF) .GT. TOL * PIHALF) GO TO 100 IF (ABS(N) .GT. 1.0) GO TO 110 IF (K2 .LT. 0.0 .OR. L2 .LT. 0.0) GO TO 120 IF (ABS((K2 + L2) - 1.0) .GT. TOL) GO TO 120 C IF (PHI .LT. 0.79) GO TO 10 S = COS(CPHI) C = SIN(CPHI) GO TO 11 10 S = SIN(PHI) C = COS(PHI) 11 A = C*C B = L2 + K2*A S2 = S*S C IF (N .GT. 0.0) GO TO 20 R = 1.0 - N*S2 GO TO 30 20 IF (M .LT. 0.0 .OR. M .GT. 1.0) GO TO 110 IF (ABS((M + N) - 1.0) .GT. TOL) GO TO 110 R = M + N*A C 30 CALL RJVAL (A, B, 1.0, R, P, IERR) IF (IERR .NE. 0) GO TO 130 P = P * (S * S2) * N/3.0 CALL RFVAL (A, B, 1.0, RF, IERR) P = P + S * RF RETURN C C ERROR RETURN C 100 IERR = 1 RETURN 110 IERR = 2 RETURN 120 IERR = 3 RETURN 130 IERR = 4 RETURN END SUBROUTINE DEPI (PHI, CPHI, K2, L2, N, M, P, IERR) C----------------------------------------------------------------------- C DOUBLE PRECISION COMPUTATION OF THE C REAL ELLIPTIC INTEGRAL OF THE THIRD KIND C----------------------------------------------------------------------- DOUBLE PRECISION PHI, CPHI, K2, L2, N, M, P DOUBLE PRECISION A, B, C, EPS, PIHALF, R, RF, S, S2, TOL DOUBLE PRECISION DPMPAR C--------------------- DATA PIHALF /1.570796326794896619231321691639751442099D0/ C----------------------------------------------------------------------- C C ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE C SMALLEST NUMBER SUCH THAT 1.D0 + EPS .GT. 1.D0. C EPS = DPMPAR(1) C C----------------------------------------------------------------------- TOL = 4.D0 * EPS IF (DMIN1(PHI,CPHI) .LT. 0.D0) GO TO 100 IF (DABS((PHI + CPHI) - PIHALF) .GT. TOL * PIHALF) GO TO 100 IF (DABS(N) .GT. 1.D0) GO TO 110 IF (K2 .LT. 0.D0 .OR. L2 .LT. 0.D0) GO TO 120 IF (DABS((K2 + L2) - 1.D0) .GT. TOL) GO TO 120 C IF (PHI .LT. 0.79D0) GO TO 10 S = DCOS(CPHI) C = DSIN(CPHI) GO TO 11 10 S = DSIN(PHI) C = DCOS(PHI) 11 A = C*C B = L2 + K2*A S2 = S*S C IF (N .GT. 0.D0) GO TO 20 R = 1.D0 - N*S2 GO TO 30 20 IF (M .LT. 0.D0 .OR. M .GT. 1.D0) GO TO 110 IF (DABS((M + N) - 1.D0) .GT. TOL) GO TO 110 R = M + N*A C 30 CALL DRJVAL (A, B, 1.D0, R, P, IERR) IF (IERR .NE. 0) GO TO 130 P = P * (S * S2) * N/3.D0 CALL DRFVAL (A, B, 1.D0, RF, IERR) P = P + S * RF RETURN C C ERROR RETURN C 100 IERR = 1 RETURN 110 IERR = 2 RETURN 120 IERR = 3 RETURN 130 IERR = 4 RETURN END SUBROUTINE RFVAL (X, Y, Z, RF, IERR) C----------------------------------------------------------------------- C C THIS SUBROUTINE COMPUTES THE INCOMPLETE ELLIPTIC INTEGRAL C OF THE FIRST KIND C C RF(X,Y,Z) = INTEGRAL FROM ZERO TO INFINITY OF C C -1/2 -1/2 -1/2 C (1/2)(T+X) (T+Y) (T+Z) DT, C C WHERE X, Y, AND Z ARE NONNEGATIVE AND AT MOST ONE OF THEM C IS ZERO. IF ONE OF THEM IS ZERO, THE INTEGRAL IS COMPLETE. C THE DUPLICATION THEOREM IS ITERATED UNTIL THE VARIABLES ARE C NEARLY EQUAL, AND THE FUNCTION IS THEN EXPANDED IN TAYLOR C SERIES TO FIFTH ORDER. REFERENCE. B. C. CARLSON, COMPUTING C ELLIPTIC INTEGRALS BY DUPLICATION, NUMER. MATH. 33 (1979), C 1-16. CODED BY B. C. CARLSON AND ELAINE M. NOTIS, AMES C LABORATORY-DOE, IOWA STATE UNIVERSITY, AMES, IOWA 50011. C MARCH 1, 1980. MODIFIED BY A.H. MORRIS (NSWC). C C----------------------------------------------------------------------- INTEGER IERR REAL RF,C1,C2,C3,E2,E3,EPSLON,ERRTOL,LAMDA REAL LOLIM,MU,S,UPLIM,X,XN,XNDEV,XNROOT REAL Y,YN,YNDEV,YNROOT,Z,ZN,ZNDEV,ZNROOT REAL SPMPAR C----------------------------------------------------------------------- C C INPUT ... C C X, Y, AND Z ARE THE VARIABLES IN THE INTEGRAL RF(X,Y,Z). C C OUTPUT ... C C RF IS THE VALUE OF THE INCOMPLETE ELLIPTIC INTEGRAL. C C IERR IS THE RETURN ERROR CODE. C IERR = 0 FOR NORMAL COMPLETION OF THE SUBROUTINE. C IERR = 1 X, Y, OR Z IS NEGATIVE. C IERR = 2 X+Y, X+Z, OR Y+Z IS TOO SMALL. C IERR = 3 X, Y, OR Z IS TOO LARGE. C C----------------------------------------------------------------------- C C MACHINE DEPENDENT PARAMETERS ... C C LOLIM AND UPLIM DETERMINE THE RANGE OF VALID ARGUMENTS. C LOLIM IS NOT LESS THAN THE MACHINE MINIMUM MULTIPLIED BY 5. C UPLIM IS NOT GREATER THAN THE MACHINE MAXIMUM DIVIDED BY 5. C LOLIM = 5.0 * SPMPAR(2) UPLIM = 0.2 * SPMPAR(3) C C ERRTOL IS SET TO THE DESIRED ERROR TOLERANCE. C RELATIVE ERROR DUE TO TRUNCATION IS LESS THAN C ERRTOL ** 6 / (4 * (1 - ERRTOL)). C ERRTOL = (3.6 * SPMPAR(1))**(1.0/6.0) C C----------------------------------------------------------------------- C WARNING. CHANGES IN THE PROGRAM MAY IMPROVE SPEED AT THE C EXPENSE OF ROBUSTNESS. C----------------------------------------------------------------------- C IF (AMIN1(X,Y,Z) .LT. 0.0) GO TO 100 IF (AMIN1(X+Y,X+Z,Y+Z) .LT. LOLIM) GO TO 110 IF (AMAX1(X,Y,Z) .GT. UPLIM) GO TO 120 C IERR = 0 XN = X YN = Y ZN = Z C 10 MU = (XN + YN + ZN) / 3.0 XNDEV = 2.0 - (MU + XN) / MU YNDEV = 2.0 - (MU + YN) / MU ZNDEV = 2.0 - (MU + ZN) / MU EPSLON = AMAX1(ABS(XNDEV),ABS(YNDEV),ABS(ZNDEV)) IF (EPSLON .LT. ERRTOL) GO TO 20 XNROOT = SQRT(XN) YNROOT = SQRT(YN) ZNROOT = SQRT(ZN) LAMDA = XNROOT * (YNROOT + ZNROOT) + YNROOT * ZNROOT XN = (XN + LAMDA) * 0.25 YN = (YN + LAMDA) * 0.25 ZN = (ZN + LAMDA) * 0.25 GO TO 10 C 20 C1 = 1.0 / 24.0 C2 = 3.0 / 44.0 C3 = 1.0 / 14.0 E2 = XNDEV * YNDEV - ZNDEV * ZNDEV E3 = XNDEV * YNDEV * ZNDEV S = 1.0 + (C1 * E2 - 0.1 - C2 * E3) * E2 + C3 * E3 RF = S / SQRT(MU) RETURN C C ERROR RETURN C 100 RF = 0.0 IERR = 1 RETURN 110 RF = 0.0 IERR = 2 RETURN 120 RF = 0.0 IERR = 3 RETURN END SUBROUTINE DRFVAL (X, Y, Z, RF, IERR) C----------------------------------------------------------------------- C C THIS SUBROUTINE COMPUTES THE INCOMPLETE ELLIPTIC INTEGRAL C OF THE FIRST KIND C C RF(X,Y,Z) = INTEGRAL FROM ZERO TO INFINITY OF C C -1/2 -1/2 -1/2 C (1/2)(T+X) (T+Y) (T+Z) DT, C C WHERE X, Y, AND Z ARE NONNEGATIVE AND AT MOST ONE OF THEM C IS ZERO. IF ONE OF THEM IS ZERO, THE INTEGRAL IS COMPLETE. C THE DUPLICATION THEOREM IS ITERATED UNTIL THE VARIABLES ARE C NEARLY EQUAL, AND THE FUNCTION IS THEN EXPANDED IN TAYLOR C SERIES TO FIFTH ORDER. REFERENCE. B. C. CARLSON, COMPUTING C ELLIPTIC INTEGRALS BY DUPLICATION, NUMER. MATH. 33 (1979), C 1-16. CODED BY B. C. CARLSON AND ELAINE M. NOTIS, AMES C LABORATORY-DOE, IOWA STATE UNIVERSITY, AMES, IOWA 50011. C MARCH 1, 1980. MODIFIED BY A.H. MORRIS (NSWC). C C----------------------------------------------------------------------- INTEGER IERR DOUBLE PRECISION RF,C1,C2,C3,E2,E3,EPSLON,ERRTOL,LAMDA DOUBLE PRECISION LOLIM,MU,S,UPLIM,X,XN,XNDEV,XNROOT DOUBLE PRECISION Y,YN,YNDEV,YNROOT,Z,ZN,ZNDEV,ZNROOT DOUBLE PRECISION DPMPAR C----------------------------------------------------------------------- C C INPUT ... C C X, Y, AND Z ARE THE VARIABLES IN THE INTEGRAL RF(X,Y,Z). C C OUTPUT ... C C RF IS THE VALUE OF THE INCOMPLETE ELLIPTIC INTEGRAL. C C IERR IS THE RETURN ERROR CODE. C IERR = 0 FOR NORMAL COMPLETION OF THE SUBROUTINE. C IERR = 1 X, Y, OR Z IS NEGATIVE. C IERR = 2 X+Y, X+Z, OR Y+Z IS TOO SMALL. C IERR = 3 X, Y, OR Z IS TOO LARGE. C C----------------------------------------------------------------------- C C MACHINE DEPENDENT PARAMETERS ... C C LOLIM AND UPLIM DETERMINE THE RANGE OF VALID ARGUMENTS. C LOLIM IS NOT LESS THAN THE MACHINE MINIMUM MULTIPLIED BY 5. C UPLIM IS NOT GREATER THAN THE MACHINE MAXIMUM DIVIDED BY 5. C LOLIM = 5.0D0 * DPMPAR(2) UPLIM = 0.2D0 * DPMPAR(3) C C ERRTOL IS SET TO THE DESIRED ERROR TOLERANCE. C RELATIVE ERROR DUE TO TRUNCATION IS LESS THAN C ERRTOL ** 6 / (4 * (1 - ERRTOL)). C ERRTOL = (3.6 * SNGL(DPMPAR(1)))**(1.0/6.0) C C----------------------------------------------------------------------- C WARNING. CHANGES IN THE PROGRAM MAY IMPROVE SPEED AT THE C EXPENSE OF ROBUSTNESS. C----------------------------------------------------------------------- C IF (DMIN1(X,Y,Z) .LT. 0.D0) GO TO 100 IF (DMIN1(X+Y,X+Z,Y+Z) .LT. LOLIM) GO TO 110 IF (DMAX1(X,Y,Z) .GT. UPLIM) GO TO 120 C IERR = 0 XN = X YN = Y ZN = Z C 10 MU = (XN + YN + ZN) / 3.D0 XNDEV = 2.D0 - (MU + XN) / MU YNDEV = 2.D0 - (MU + YN) / MU ZNDEV = 2.D0 - (MU + ZN) / MU EPSLON = DMAX1(DABS(XNDEV),DABS(YNDEV),DABS(ZNDEV)) IF (EPSLON .LT. ERRTOL) GO TO 20 XNROOT = DSQRT(XN) YNROOT = DSQRT(YN) ZNROOT = DSQRT(ZN) LAMDA = XNROOT * (YNROOT + ZNROOT) + YNROOT * ZNROOT XN = (XN + LAMDA) * 0.25D0 YN = (YN + LAMDA) * 0.25D0 ZN = (ZN + LAMDA) * 0.25D0 GO TO 10 C 20 C1 = 1.D0 / 24.D0 C2 = 3.D0 / 44.D0 C3 = 1.D0 / 14.D0 E2 = XNDEV * YNDEV - ZNDEV * ZNDEV E3 = XNDEV * YNDEV * ZNDEV S = 1.D0 + (C1 * E2 - 0.1D0 - C2 * E3) * E2 + C3 * E3 RF = S / DSQRT(MU) RETURN C C ERROR RETURN C 100 RF = 0.D0 IERR = 1 RETURN 110 RF = 0.D0 IERR = 2 RETURN 120 RF = 0.D0 IERR = 3 RETURN END SUBROUTINE RDVAL (X, Y, Z, RD, IERR) C----------------------------------------------------------------------- C C THIS SUBROUTINE COMPUTES THE INCOMPLETE ELLIPTIC INTEGRAL C OF THE SECOND KIND C C RD(X,Y,Z) = INTEGRAL FROM ZERO TO INFINITY OF C C -1/2 -1/2 -3/2 C (3/2)(T+X) (T+Y) (T+Z) DT, C C WHERE X AND Y ARE NONNEGATIVE, X + Y IS POSITIVE, AND Z IS C POSITIVE. IF X OR Y IS ZERO, THE INTEGRAL IS COMPLETE. C THE DUPLICATION THEOREM IS ITERATED UNTIL THE VARIABLES ARE C NEARLY EQUAL, AND THE FUNCTION IS THEN EXPANDED IN TAYLOR C SERIES TO FIFTH ORDER. REFERENCE. B. C. CARLSON, COMPUTING C ELLIPTIC INTEGRALS BY DUPLICATION, NUMER. MATH. 33 (1979), C 1-16. CODED BY B. C. CARLSON AND ELAINE M. NOTIS, AMES C LABORATORY-DOE, IOWA STATE UNIVERSITY, AMES, IOWA 50011. C MARCH 1, 1980. MODIFIED BY A.H. MORRIS (NSWC). C C----------------------------------------------------------------------- INTEGER IERR REAL RD,C1,C2,C3,C4,EA,EB,EC,ED,EF,EPSLON,ERRTOL,LAMDA REAL LOLIM,MU,POWER4,SIGMA,S1,S2,UPLIM,X,XN,XNDEV REAL XNROOT,Y,YN,YNDEV,YNROOT,Z,ZN,ZNDEV,ZNROOT REAL SPMPAR C----------------------------------------------------------------------- C C INPUT ... C C X, Y, AND Z ARE THE VARIABLES IN THE INTEGRAL RD(X,Y,Z). C C OUTPUT ... C C RD IS THE VALUE OF THE INCOMPLETE ELLIPTIC INTEGRAL. C C IERR IS THE RETURN ERROR CODE. C IERR = 0 FOR NORMAL COMPLETION OF THE SUBROUTINE. C IERR = 1 X, Y, OR Z IS NEGATIVE. C IERR = 2 X+Y OR Z IS TOO SMALL. C IERR = 3 X, Y, OR Z IS TOO LARGE. C C----------------------------------------------------------------------- C C MACHINE DEPENDENT PARAMETERS ... C C ERRTOL IS SET TO THE DESIRED ERROR TOLERANCE. C RELATIVE ERROR DUE TO TRUNCATION IS LESS THAN C 3 * ERRTOL ** 6 / (1 - ERRTOL) ** 3/2. C ERRTOL = (.28 * SPMPAR(1)) ** (1.0/6.0) C C LOLIM AND UPLIM DETERMINE THE RANGE OF VALID ARGUMENTS. C LOLIM IS NOT LESS THAN 2 / (MACHINE MAXIMUM) ** (2/3). C UPLIM IS NOT GREATER THAN (0.1 * ERRTOL / MACHINE C MINIMUM) ** (2/3). C MU = -2.0/3.0 LOLIM = 2.0001 * SPMPAR(3) ** MU UPLIM = (10.0 * SPMPAR(2) / ERRTOL) ** MU C C----------------------------------------------------------------------- C WARNING. CHANGES IN THE PROGRAM MAY IMPROVE SPEED AT THE C EXPENSE OF ROBUSTNESS. C----------------------------------------------------------------------- C IF (AMIN1(X,Y,Z) .LT. 0.0) GO TO 100 IF (AMIN1(X+Y,Z) .LT. LOLIM) GO TO 110 IF (AMAX1(X,Y,Z) .GT. UPLIM) GO TO 120 C IERR = 0 XN = X YN = Y ZN = Z SIGMA = 0.0 POWER4 = 1.0 C 10 MU = (XN + YN + 3.0 * ZN) * 0.2 XNDEV = (MU - XN) / MU YNDEV = (MU - YN) / MU ZNDEV = (MU - ZN) / MU EPSLON = AMAX1(ABS(XNDEV),ABS(YNDEV),ABS(ZNDEV)) IF (EPSLON .LT. ERRTOL) GO TO 20 XNROOT = SQRT(XN) YNROOT = SQRT(YN) ZNROOT = SQRT(ZN) LAMDA = XNROOT * (YNROOT + ZNROOT) + YNROOT * ZNROOT SIGMA = SIGMA + POWER4 / (ZNROOT * (ZN + LAMDA)) POWER4 = POWER4 * 0.25 XN = (XN + LAMDA) * 0.25 YN = (YN + LAMDA) * 0.25 ZN = (ZN + LAMDA) * 0.25 GO TO 10 C 20 C1 = 3.0 / 14.0 C2 = 1.0 / 6.0 C3 = 9.0 / 22.0 C4 = 3.0 / 26.0 EA = XNDEV * YNDEV EB = ZNDEV * ZNDEV EC = EA - EB ED = EA - 6.0 * EB EF = ED + EC + EC S1 = ED * (- C1 + 0.25 * C3 * ED - 1.5 * C4 * ZNDEV * EF) S2 = ZNDEV * (C2 * EF + ZNDEV * (- C3 * EC + ZNDEV * C4 * EA)) RD = 3.0 * SIGMA + POWER4 * (1.0 + S1 + S2) / (MU * SQRT(MU)) RETURN C C ERROR RETURN C 100 RD = 0.0 IERR = 1 RETURN 110 RD = 0.0 IERR = 2 RETURN 120 RD = 0.0 IERR = 3 RETURN END SUBROUTINE DRDVAL (X, Y, Z, RD, IERR) C----------------------------------------------------------------------- C C THIS SUBROUTINE COMPUTES THE INCOMPLETE ELLIPTIC INTEGRAL C OF THE SECOND KIND C C RD(X,Y,Z) = INTEGRAL FROM ZERO TO INFINITY OF C C -1/2 -1/2 -3/2 C (3/2)(T+X) (T+Y) (T+Z) DT, C C WHERE X AND Y ARE NONNEGATIVE, X + Y IS POSITIVE, AND Z IS C POSITIVE. IF X OR Y IS ZERO, THE INTEGRAL IS COMPLETE. C THE DUPLICATION THEOREM IS ITERATED UNTIL THE VARIABLES ARE C NEARLY EQUAL, AND THE FUNCTION IS THEN EXPANDED IN TAYLOR C SERIES TO FIFTH ORDER. REFERENCE. B. C. CARLSON, COMPUTING C ELLIPTIC INTEGRALS BY DUPLICATION, NUMER. MATH. 33 (1979), C 1-16. CODED BY B. C. CARLSON AND ELAINE M. NOTIS, AMES C LABORATORY-DOE, IOWA STATE UNIVERSITY, AMES, IOWA 50011. C MARCH 1, 1980. MODIFIED BY A.H. MORRIS (NSWC). C C----------------------------------------------------------------------- INTEGER IERR DOUBLE PRECISION RD,C1,C2,C3,C4,EA,EB,EC,ED,EF,EPSLON,ERRTOL,LAMDA DOUBLE PRECISION LOLIM,MU,POWER4,SIGMA,S1,S2,UPLIM,X,XN,XNDEV DOUBLE PRECISION XNROOT,Y,YN,YNDEV,YNROOT,Z,ZN,ZNDEV,ZNROOT DOUBLE PRECISION DPMPAR C----------------------------------------------------------------------- C C INPUT ... C C X, Y, AND Z ARE THE VARIABLES IN THE INTEGRAL RD(X,Y,Z). C C OUTPUT ... C C RD IS THE VALUE OF THE INCOMPLETE ELLIPTIC INTEGRAL. C C IERR IS THE RETURN ERROR CODE. C IERR = 0 FOR NORMAL COMPLETION OF THE SUBROUTINE. C IERR = 1 X, Y, OR Z IS NEGATIVE. C IERR = 2 X+Y OR Z IS TOO SMALL. C IERR = 3 X, Y, OR Z IS TOO LARGE. C C----------------------------------------------------------------------- C C MACHINE DEPENDENT PARAMETERS ... C C ERRTOL IS SET TO THE DESIRED ERROR TOLERANCE. C RELATIVE ERROR DUE TO TRUNCATION IS LESS THAN C 3 * ERRTOL ** 6 / (1 - ERRTOL) ** 3/2. C ERRTOL = (.28 * SNGL(DPMPAR(1)))**(1.0/6.0) C C LOLIM AND UPLIM DETERMINE THE RANGE OF VALID ARGUMENTS. C LOLIM IS NOT LESS THAN 2 / (MACHINE MAXIMUM) ** (2/3). C UPLIM IS NOT GREATER THAN (0.1 * ERRTOL / MACHINE C MINIMUM) ** (2/3). C MU = -2.D0/3.D0 LOLIM = 2.00000000001D0 * DPMPAR(3) ** MU UPLIM = (10.D0 * DPMPAR(2) / ERRTOL) ** MU C C----------------------------------------------------------------------- C WARNING. CHANGES IN THE PROGRAM MAY IMPROVE SPEED AT THE C EXPENSE OF ROBUSTNESS. C----------------------------------------------------------------------- C IF (DMIN1(X,Y,Z) .LT. 0.D0) GO TO 100 IF (DMIN1(X+Y,Z) .LT. LOLIM) GO TO 110 IF (DMAX1(X,Y,Z) .GT. UPLIM) GO TO 120 C IERR = 0 XN = X YN = Y ZN = Z SIGMA = 0.D0 POWER4 = 1.D0 C 10 MU = (XN + YN + 3.D0 * ZN) * 0.2D0 XNDEV = (MU - XN) / MU YNDEV = (MU - YN) / MU ZNDEV = (MU - ZN) / MU EPSLON = DMAX1(DABS(XNDEV),DABS(YNDEV),DABS(ZNDEV)) IF (EPSLON .LT. ERRTOL) GO TO 20 XNROOT = DSQRT(XN) YNROOT = DSQRT(YN) ZNROOT = DSQRT(ZN) LAMDA = XNROOT * (YNROOT + ZNROOT) + YNROOT * ZNROOT SIGMA = SIGMA + POWER4 / (ZNROOT * (ZN + LAMDA)) POWER4 = POWER4 * 0.25D0 XN = (XN + LAMDA) * 0.25D0 YN = (YN + LAMDA) * 0.25D0 ZN = (ZN + LAMDA) * 0.25D0 GO TO 10 C 20 C1 = 3.D0 / 14.D0 C2 = 1.D0 / 6.D0 C3 = 9.D0 / 22.D0 C4 = 3.D0 / 26.D0 EA = XNDEV * YNDEV EB = ZNDEV * ZNDEV EC = EA - EB ED = EA - 6.D0 * EB EF = ED + EC + EC S1 = ED * (- C1 + 0.25D0 * C3 * ED - 1.5D0 * C4 * ZNDEV * EF) S2 = ZNDEV * (C2 * EF + ZNDEV * (- C3 * EC + ZNDEV * C4 * EA)) RD = 3.D0 * SIGMA + POWER4 * (1.D0 + S1 + S2) / (MU * DSQRT(MU)) RETURN C C ERROR RETURN C 100 RD = 0.D0 IERR = 1 RETURN 110 RD = 0.D0 IERR = 2 RETURN 120 RD = 0.D0 IERR = 3 RETURN END SUBROUTINE RJVAL (X, Y, Z, P, RJ, IERR) C----------------------------------------------------------------------- C C THIS SUBROUTINE COMPUTES THE INCOMPLETE ELLIPTIC INTEGRAL C OF THE THIRD KIND C C RJ(X,Y,Z,P) = INTEGRAL FROM ZERO TO INFINITY OF C C -1/2 -1/2 -1/2 -1 C (3/2)(T+X) (T+Y) (T+Z) (T+P) DT, C C WHERE X, Y, AND Z ARE NONNEGATIVE, AT MOST ONE OF THEM IS C ZERO, AND P IS POSITIVE. IF X OR Y OR Z IS ZERO, THE C INTEGRAL IS COMPLETE. THE DUPLICATION THEOREM IS ITERATED C UNTIL THE VARIABLES ARE NEARLY EQUAL, AND THE FUNCTION IS C THEN EXPANDED IN TAYLOR SERIES TO FIFTH ORDER. REFERENCE. C B. C. CARLSON, COMPUTING ELLIPTIC INTEGRALS BY DUPLICATION, C NUMER. MATH. 33 (1979), 1-16. CODED BY B. C. CARLSON AND C ELAINE M. NOTIS, AMES LABORATORY-DOE, IOWA STATE UNIVERSITY, C AMES, IOWA 50011. MARCH 1, 1980. MODIFIED BY A.H. MORRIS C (NSWC). C C----------------------------------------------------------------------- INTEGER IERR REAL RJ,RC,ALFA,BETA,C1,C2,C3,C4,EA,EB,EC,E2,E3 REAL EPSLON,ERRTOL,ETOLRC,LAMDA,LOLIM,MU,P,PN,PNDEV REAL POWER4,SIGMA,S1,S2,S3,UPLIM,X,XN,XNDEV REAL XNROOT,Y,YN,YNDEV,YNROOT,Z,ZN,ZNDEV,ZNROOT REAL SPMPAR C----------------------------------------------------------------------- C C INPUT ... C C X, Y, Z, AND P ARE THE VARIABLES IN THE INTEGRAL RJ(X,Y,Z,P). C C OUTPUT ... C C RJ IS THE VALUE OF THE INCOMPLETE ELLIPTIC INTEGRAL. C C IERR IS THE RETURN ERROR CODE. C IERR = 0 FOR NORMAL COMPLETION OF THE SUBROUTINE. C IERR = 1 X, Y, Z, OR P IS NEGATIVE. C IERR = 2 X+Y, X+Z, Y+Z, OR P IS TOO SMALL. C IERR = 3 X, Y, Z, OR P IS TOO LARGE. C C----------------------------------------------------------------------- C C MACHINE DEPENDENT PARAMETERS ... C C RC IS A FUNCTION COMPUTED BY THE SUBROUTINE RCVAL1. C LOLIM AND UPLIM DETERMINE THE RANGE OF VALID ARGUMENTS. C LOLIM IS NOT LESS THAN THE CUBE ROOT OF THE VALUE C OF LOLIM USED IN THE CODE FOR RC, AND C UPLIM IS NOT GREATER THAN 0.3 TIMES THE CUBE ROOT OF C THE VALUE OF UPLIM USED IN THE CODE FOR RC. C MU = 1.0/3.0 LOLIM = 1.0001 * (5.0 * SPMPAR(2))**MU UPLIM = .29999 * (0.2 * SPMPAR(3))**MU C C ERRTOL IS SET TO THE DESIRED ERROR TOLERANCE. THE C RELATIVE ERROR DUE TO TRUNCATION OF THE SERIES FOR RJ C IS LESS THAN 3 * ERRTOL ** 6 / (1 - ERRTOL) ** 3/2. C AN ERROR TOLERANCE (ETOLRC) WILL BE PASSED TO THE CODE FOR C RC TO MAKE THE TRUNCATION ERROR FOR RC LESS THAN FOR RJ. C ERRTOL = (.28 * SPMPAR(1))**(1.0/6.0) C C----------------------------------------------------------------------- C WARNING. CHANGES IN THE PROGRAM MAY IMPROVE SPEED AT THE C EXPENSE OF ROBUSTNESS. C----------------------------------------------------------------------- C IF (AMIN1(X,Y,Z,P) .LT. 0.0) GO TO 100 IF (AMIN1(X+Y,X+Z,Y+Z,P) .LT. LOLIM) GO TO 110 IF (AMAX1(X,Y,Z,P) .GT. UPLIM) GO TO 120 C IERR = 0 XN = X YN = Y ZN = Z PN = P SIGMA = 0.0 POWER4 = 1.0 ETOLRC = 0.5 * ERRTOL C 10 MU = (XN + YN + ZN + PN + PN) * 0.2 XNDEV = (MU - XN) / MU YNDEV = (MU - YN) / MU ZNDEV = (MU - ZN) / MU PNDEV = (MU - PN) / MU EPSLON = AMAX1(ABS(XNDEV),ABS(YNDEV),ABS(ZNDEV),ABS(PNDEV)) IF (EPSLON .LT. ERRTOL) GO TO 20 XNROOT = SQRT(XN) YNROOT = SQRT(YN) ZNROOT = SQRT(ZN) LAMDA = XNROOT * (YNROOT + ZNROOT) + YNROOT * ZNROOT ALFA = PN * (XNROOT + YNROOT + ZNROOT) + XNROOT * YNROOT * ZNROOT ALFA = ALFA * ALFA BETA = PN * (PN + LAMDA) * (PN + LAMDA) CALL RCVAL1 (ALFA, BETA, ETOLRC, RC, IERR) IF (IERR .NE. 0) RETURN SIGMA = SIGMA + POWER4 * RC POWER4 = POWER4 * 0.25 XN = (XN + LAMDA) * 0.25 YN = (YN + LAMDA) * 0.25 ZN = (ZN + LAMDA) * 0.25 PN = (PN + LAMDA) * 0.25 GO TO 10 C 20 C1 = 3.0 / 14.0 C2 = 1.0 / 3.0 C3 = 3.0 / 22.0 C4 = 3.0 / 26.0 EA = XNDEV * (YNDEV + ZNDEV) + YNDEV * ZNDEV EB = XNDEV * YNDEV * ZNDEV EC = PNDEV * PNDEV E2 = EA - 3.0 * EC E3 = EB + 2.0 * PNDEV * (EA - EC) S1 = 1.0 + E2 * (-C1 + 0.75 * C3 * E2 - 1.5 * C4 * E3) S2 = EB * (0.5 * C2 + PNDEV * (- C3 - C3 + PNDEV * C4)) S3 = PNDEV * EA * (C2 - PNDEV * C3) - C2 * PNDEV * EC RJ = 3.0 * SIGMA + POWER4 * (S1 + S2 + S3) / (MU * SQRT(MU)) RETURN C C ERROR RETURN C 100 RJ = 0.0 IERR = 1 RETURN 110 RJ = 0.0 IERR = 2 RETURN 120 RJ = 0.0 IERR = 3 RETURN END SUBROUTINE DRJVAL (X, Y, Z, P, RJ, IERR) C----------------------------------------------------------------------- C C THIS SUBROUTINE COMPUTES THE INCOMPLETE ELLIPTIC INTEGRAL C OF THE THIRD KIND C C RJ(X,Y,Z,P) = INTEGRAL FROM ZERO TO INFINITY OF C C -1/2 -1/2 -1/2 -1 C (3/2)(T+X) (T+Y) (T+Z) (T+P) DT, C C WHERE X, Y, AND Z ARE NONNEGATIVE, AT MOST ONE OF THEM IS C ZERO, AND P IS POSITIVE. IF X OR Y OR Z IS ZERO, THE C INTEGRAL IS COMPLETE. THE DUPLICATION THEOREM IS ITERATED C UNTIL THE VARIABLES ARE NEARLY EQUAL, AND THE FUNCTION IS C THEN EXPANDED IN TAYLOR SERIES TO FIFTH ORDER. REFERENCE. C B. C. CARLSON, COMPUTING ELLIPTIC INTEGRALS BY DUPLICATION, C NUMER. MATH. 33 (1979), 1-16. CODED BY B. C. CARLSON AND C ELAINE M. NOTIS, AMES LABORATORY-DOE, IOWA STATE UNIVERSITY, C AMES, IOWA 50011. MARCH 1, 1980. MODIFIED BY A.H. MORRIS C (NSWC). C C----------------------------------------------------------------------- INTEGER IERR DOUBLE PRECISION RJ,RC,ALFA,BETA,C1,C2,C3,C4,EA,EB,EC,E2,E3 DOUBLE PRECISION EPSLON,ERRTOL,ETOLRC,LAMDA,LOLIM,MU,P,PN,PNDEV DOUBLE PRECISION POWER4,SIGMA,S1,S2,S3,UPLIM,X,XN,XNDEV DOUBLE PRECISION XNROOT,Y,YN,YNDEV,YNROOT,Z,ZN,ZNDEV,ZNROOT DOUBLE PRECISION DPMPAR C----------------------------------------------------------------------- C C INPUT ... C C X, Y, Z, AND P ARE THE VARIABLES IN THE INTEGRAL RJ(X,Y,Z,P). C C OUTPUT ... C C RJ IS THE VALUE OF THE INCOMPLETE ELLIPTIC INTEGRAL. C C IERR IS THE RETURN ERROR CODE. C IERR = 0 FOR NORMAL COMPLETION OF THE SUBROUTINE. C IERR = 1 X, Y, Z, OR P IS NEGATIVE. C IERR = 2 X+Y, X+Z, Y+Z, OR P IS TOO SMALL. C IERR = 3 X, Y, Z, OR P IS TOO LARGE. C C----------------------------------------------------------------------- C C MACHINE DEPENDENT PARAMETERS ... C C RC IS A FUNCTION COMPUTED BY THE SUBROUTINE DRCVL1. C LOLIM AND UPLIM DETERMINE THE RANGE OF VALID ARGUMENTS. C LOLIM IS NOT LESS THAN THE CUBE ROOT OF THE VALUE C OF LOLIM USED IN THE CODE FOR RC, AND C UPLIM IS NOT GREATER THAN 0.3 TIMES THE CUBE ROOT OF C THE VALUE OF UPLIM USED IN THE CODE FOR RC. C MU = 1.D0/3.D0 LOLIM = 1.00000000001D0 * (5.0D0 * DPMPAR(2))**MU UPLIM = .299999999999D0 * (0.2D0 * DPMPAR(3))**MU C C ERRTOL IS SET TO THE DESIRED ERROR TOLERANCE. C RELATIVE ERROR DUE TO TRUNCATION OF THE SERIES FOR RJ C IS LESS THAN 3 * ERRTOL ** 6 / (1 - ERRTOL) ** 3/2. C AN ERROR TOLERANCE (ETOLRC) WILL BE PASSED TO THE CODE FOR C RC TO MAKE THE TRUNCATION ERROR FOR RC LESS THAN FOR RJ. C ERRTOL = (.28 * SNGL(DPMPAR(1)))**(1.0/6.0) C C----------------------------------------------------------------------- C WARNING. CHANGES IN THE PROGRAM MAY IMPROVE SPEED AT THE C EXPENSE OF ROBUSTNESS. C----------------------------------------------------------------------- C IF (DMIN1(X,Y,Z,P) .LT. 0.D0) GO TO 100 IF (DMIN1(X+Y,X+Z,Y+Z,P) .LT. LOLIM) GO TO 110 IF (DMAX1(X,Y,Z,P) .GT. UPLIM) GO TO 120 C IERR = 0 XN = X YN = Y ZN = Z PN = P SIGMA = 0.D0 POWER4 = 1.D0 ETOLRC = 0.5D0 * ERRTOL C 10 MU = (XN + YN + ZN + PN + PN) * 0.2D0 XNDEV = (MU - XN) / MU YNDEV = (MU - YN) / MU ZNDEV = (MU - ZN) / MU PNDEV = (MU - PN) / MU EPSLON = DMAX1(DABS(XNDEV),DABS(YNDEV),DABS(ZNDEV),DABS(PNDEV)) IF (EPSLON .LT. ERRTOL) GO TO 20 XNROOT = DSQRT(XN) YNROOT = DSQRT(YN) ZNROOT = DSQRT(ZN) LAMDA = XNROOT * (YNROOT + ZNROOT) + YNROOT * ZNROOT ALFA = PN * (XNROOT + YNROOT + ZNROOT) + XNROOT * YNROOT * ZNROOT ALFA = ALFA * ALFA BETA = PN * (PN + LAMDA) * (PN + LAMDA) CALL DRCVL1 (ALFA, BETA, ETOLRC, RC, IERR) IF (IERR .NE. 0) RETURN SIGMA = SIGMA + POWER4 * RC POWER4 = POWER4 * 0.25D0 XN = (XN + LAMDA) * 0.25D0 YN = (YN + LAMDA) * 0.25D0 ZN = (ZN + LAMDA) * 0.25D0 PN = (PN + LAMDA) * 0.25D0 GO TO 10 C 20 C1 = 3.D0 / 14.D0 C2 = 1.D0 / 3.D0 C3 = 3.D0 / 22.D0 C4 = 3.D0 / 26.D0 EA = XNDEV * (YNDEV + ZNDEV) + YNDEV * ZNDEV EB = XNDEV * YNDEV * ZNDEV EC = PNDEV * PNDEV E2 = EA - 3.D0 * EC E3 = EB + 2.D0 * PNDEV * (EA - EC) S1 = 1.D0 + E2 * (- C1 + 0.75D0 * C3 * E2 - 1.5D0 * C4 * E3) S2 = EB * (0.5D0 * C2 + PNDEV * (- C3 - C3 + PNDEV * C4)) S3 = PNDEV * EA * (C2 - PNDEV * C3) - C2 * PNDEV * EC RJ = 3.D0 * SIGMA + POWER4 * (S1 + S2 + S3) / (MU * DSQRT(MU)) RETURN C C ERROR RETURN C 100 RJ = 0.D0 IERR = 1 RETURN 110 RJ = 0.D0 IERR = 2 RETURN 120 RJ = 0.D0 IERR = 3 RETURN END SUBROUTINE RCVAL1 (X, Y, ERRTOL, RC, IERR) C----------------------------------------------------------------------- C C THIS SUBROUTINE COMPUTES THE INTEGRAL C C RC(X,Y) = INTEGRAL FROM ZERO TO INFINITY OF C C -1/2 -1 C (1/2)(T+X) (T+Y) DT, C C WHERE X IS NONNEGATIVE AND Y IS POSITIVE. THE DUPLICATION C THEOREM IS ITERATED UNTIL THE VARIABLES ARE NEARLY EQUAL, C AND THE FUNCTION IS THEN EXPANDED IN TAYLOR SERIES TO FIFTH C ORDER. LOGARITHMIC, INVERSE CIRCULAR, AND INVERSE HYPER- C BOLIC FUNCTIONS CAN BE EXPRESSED IN TERMS OF RC. REFERENCE. C B. C. CARLSON, COMPUTING ELLIPTIC INTEGRALS BY DUPLICATION, C NUMER. MATH. 33 (1979), 1-16. CODED BY B. C. CARLSON AND C ELAINE M. NOTIS, AMES LABORATORY-DOE, IOWA STATE UNIVERSITY, C AMES, IOWA 50011. MARCH 1, 1980. MODIFIED BY A.H. MORRIS C (NSWC). C C----------------------------------------------------------------------- INTEGER IERR REAL RC,C1,C2,ERRTOL,LAMDA,LOLIM REAL MU,S,SN,UPLIM,X,XN,Y,YN REAL SPMPAR C----------------------------------------------------------------------- C C LOLIM AND UPLIM DETERMINE THE RANGE OF VALID ARGUMENTS. C LOLIM IS NOT LESS THAN THE MACHINE MINIMUM MULTIPLIED BY 5. C UPLIM IS NOT GREATER THAN THE MACHINE MAXIMUM DIVIDED BY 5. C LOLIM = 5.0 * SPMPAR(2) UPLIM = 0.2 * SPMPAR(3) C C INPUT ... C C X AND Y ARE THE VARIABLES IN THE INTEGRAL RC(X,Y). C C ERRTOL IS SET TO THE DESIRED ERROR TOLERANCE. C RELATIVE ERROR DUE TO TRUNCATION IS LESS THAN C 16 * ERRTOL ** 6 / (1 - 2 * ERRTOL). C C SAMPLE CHOICES ERRTOL RELATIVE TRUNCATION C ERROR LESS THAN C 1.E-3 2.E-17 C 3.E-3 2.E-14 C 1.E-2 2.E-11 C 3.E-2 2.E-8 C 1.E-1 2.E-5 C C OUTPUT ... C C RC IS THE VALUE OF THE INTEGRAL. C C IERR IS THE RETURN ERROR CODE. C IERR = 0 FOR NORMAL COMPLETION OF THE SUBROUTINE. C IERR = 1 X OR Y IS NEGATIVE, OR Y = 0. C IERR = 2 X+Y IS TOO SMALL. C IERR = 3 X OR Y IS TOO LARGE. C C----------------------------------------------------------------------- C WARNING. CHANGES IN THE PROGRAM MAY IMPROVE SPEED AT THE C EXPENSE OF ROBUSTNESS. C----------------------------------------------------------------------- C IF (X .LT. 0.0 .OR. Y .LE. 0.0) GO TO 100 IF ((X + Y) .LT. LOLIM) GO TO 110 IF (AMAX1(X,Y) .GT. UPLIM) GO TO 120 C IERR = 0 XN = X YN = Y C 10 MU = (XN + YN + YN) / 3.0 SN = (YN + MU) / MU - 2.0 IF (ABS(SN) .LT. ERRTOL) GO TO 20 LAMDA = 2.0 * SQRT(XN) * SQRT(YN) + YN XN = (XN + LAMDA) * 0.25 YN = (YN + LAMDA) * 0.25 GO TO 10 C 20 C1 = 1.0 / 7.0 C2 = 9.0 / 22.0 S = SN * SN * (0.3 + SN * (C1 + SN * (0.375 + SN * C2))) RC = (1.0 + S) / SQRT(MU) RETURN C C ERROR RETURN C 100 RC = 0.0 IERR = 1 RETURN 110 RC = 0.0 IERR = 2 RETURN 120 RC = 0.0 IERR = 3 RETURN END SUBROUTINE DRCVL1 (X, Y, ERRTOL, RC, IERR) C----------------------------------------------------------------------- C C THIS SUBROUTINE COMPUTES THE INTEGRAL C C RC(X,Y) = INTEGRAL FROM ZERO TO INFINITY OF C C -1/2 -1 C (1/2)(T+X) (T+Y) DT, C C WHERE X IS NONNEGATIVE AND Y IS POSITIVE. THE DUPLICATION C THEOREM IS ITERATED UNTIL THE VARIABLES ARE NEARLY EQUAL, C AND THE FUNCTION IS THEN EXPANDED IN TAYLOR SERIES TO FIFTH C ORDER. LOGARITHMIC, INVERSE CIRCULAR, AND INVERSE HYPER- C BOLIC FUNCTIONS CAN BE EXPRESSED IN TERMS OF RC. REFERENCE. C B. C. CARLSON, COMPUTING ELLIPTIC INTEGRALS BY DUPLICATION, C NUMER. MATH. 33 (1979), 1-16. CODED BY B. C. CARLSON AND C ELAINE M. NOTIS, AMES LABORATORY-DOE, IOWA STATE UNIVERSITY, C AMES, IOWA 50011. MARCH 1, 1980. MODIFIED BY A.H. MORRIS C (NSWC). C C----------------------------------------------------------------------- INTEGER IERR DOUBLE PRECISION RC,C1,C2,ERRTOL,LAMDA,LOLIM DOUBLE PRECISION MU,S,SN,UPLIM,X,XN,Y,YN DOUBLE PRECISION DPMPAR C----------------------------------------------------------------------- C C LOLIM AND UPLIM DETERMINE THE RANGE OF VALID ARGUMENTS. C LOLIM IS NOT LESS THAN THE MACHINE MINIMUM MULTIPLIED BY 5. C UPLIM IS NOT GREATER THAN THE MACHINE MAXIMUM DIVIDED BY 5. C LOLIM = 5.0D0 * DPMPAR(2) UPLIM = 0.2D0 * DPMPAR(3) C C INPUT ... C C X AND Y ARE THE VARIABLES IN THE INTEGRAL RC(X,Y). C C ERRTOL IS SET TO THE DESIRED ERROR TOLERANCE. C RELATIVE ERROR DUE TO TRUNCATION IS LESS THAN C 16 * ERRTOL ** 6 / (1 - 2 * ERRTOL). C C OUTPUT ... C C RC IS THE VALUE OF THE INTEGRAL. C C IERR IS THE RETURN ERROR CODE. C IERR = 0 FOR NORMAL COMPLETION OF THE SUBROUTINE. C IERR = 1 X OR Y IS NEGATIVE, OR Y = 0. C IERR = 2 X+Y IS TOO SMALL. C IERR = 3 X OR Y IS TOO LARGE. C C----------------------------------------------------------------------- C WARNING. CHANGES IN THE PROGRAM MAY IMPROVE SPEED AT THE C EXPENSE OF ROBUSTNESS. C----------------------------------------------------------------------- C IF (X .LT. 0.D0 .OR. Y .LE. 0.D0) GO TO 100 IF ((X + Y) .LT. LOLIM) GO TO 110 IF (DMAX1(X,Y) .GT. UPLIM) GO TO 120 C IERR = 0 XN = X YN = Y C 10 MU = (XN + YN + YN) / 3.D0 SN = (YN + MU) / MU - 2.D0 IF (DABS(SN) .LT. ERRTOL) GO TO 20 LAMDA = 2.D0 * DSQRT(XN) * DSQRT(YN) + YN XN = (XN + LAMDA) * 0.25D0 YN = (YN + LAMDA) * 0.25D0 GO TO 10 C 20 C1 = 1.D0 / 7.D0 C2 = 9.D0 / 22.D0 S = SN * SN * (0.3D0 + SN * (C1 + SN * (0.375D0 + SN * C2))) RC = (1.D0 + S) / DSQRT(MU) RETURN C C ERROR RETURN C 100 RC = 0.D0 IERR = 1 RETURN 110 RC = 0.D0 IERR = 2 RETURN 120 RC = 0.D0 IERR = 3 RETURN END SUBROUTINE ELLPF(U,K,L,S,C,D,IERR) C ------------------------------------------------------------- C ELLPF CALCULATES THE ELLIPTIC FUNCTIONS SN(U,K), CN(U,K), AND C DN(U,K) FOR REAL U AND REAL MODULUS K. IT IS ASSUMED THAT C ABS(K) .LE. 1. AND K**2 + L**2 = 1. C ------------------------------------------------------------- REAL K, L DATA PIHALF /1.5707963267949/ C ---------------- C ****** MAX AND EPS ARE MACHINE DEPENDENT CONSTANTS. C MAX IS THE LARGEST POSITIVE INTEGER THAT MAY C BE USED, AND EPS IS THE SMALLEST REAL NUMBER C FOR WHICH 1 + EPS .GT. 1. C MAX = IPMPAR(3) EPS = SPMPAR(1) C C ---------------- C CALCULATION FOR L = 0.0 C IF (L .NE. 0.0) GO TO 10 S = TANH(U) E = EXP(-ABS(U)) C = 2.0*E/(1.0 + E*E) D = C IERR = 0 RETURN C C CHECK THAT K**2 + L**2 = 1 C 10 TOL = 2.0*EPS Z = DBLE(K*K) + (DBLE(L*L) - 1.D0) IF (ABS(Z) .GT. TOL) GO TO 100 C F = PIHALF IF (K .NE. 0.0) CALL ELLPI(PIHALF,0.0,K,L,F,E,IERR) F2 = 2.0*F C C ARGUMENT REDUCTION C U1 = ABS(U) R = U1/F2 IF (R .GE. AMIN1(FLOAT(MAX),1.0/EPS)) GO TO 110 N = INT(R) U1 = U1 - FLOAT(N)*F2 SG = 1.0 IF (MOD(N,2) .NE. 0) SG = -1.0 C IF (U1 .LE. 0.0) GO TO 30 IF (U1 .LE. F) GO TO 20 U1 = U1 - F2 SG = -SG IF (U1 .GE. 0.0) GO TO 30 C C CALCULATION OF ELLIPTIC FUNCTIONS FOR 0.0 .LE. U2 .LE. F(K) C 20 U2 = ABS(U1) CALL SCD (U2,ABS(K),ABS(L),F,S,C,D) IERR = 0 IF (U1 .LT. 0.0) S = -S C C FINAL ASSEMBLY C S = SG*S C = SG*C IF (U .LT. 0.0) S = -S RETURN C C U IS AN INTEGER MULTIPLE OF F2 C 30 S = 0.0 C = SG D = 1.0 IERR = 0 RETURN C C ERROR RETURN C 100 IERR = 1 RETURN 110 IERR = 2 RETURN END SUBROUTINE SCD(U,K,L,F,S,C,D) C -------------------------------------------------------- C SCD COMPUTES THE ELLIPTIC FUNCTIONS SN(U,K), CN(U,K), C AND DN(U,K) FOR REAL U AND REAL MODULUS K SUCH THAT C 0.0 .LE. U .LE. F AND 0.0 .LE. K .LT. 1.0, WHERE C F = F(K) IS THE COMPLETE ELLIPTIC INTEGRAL OF THE C FIRST KIND, AND F1 = F(L) IS THE COMPLEMENTARY INTEGRAL. C IT IS ASSUMED THAT K**2 + L**2 = 1. C -------------------------------------------------------- REAL K, L DATA PIHALF /1.5707963267949/ C ------------------------ IF (K .EQ. 0.0) GO TO 40 V = F - U C C USES MACLAURIN EXPANSION WHEN U OR V .LE. 0.01 C IF (U .GT. 0.01) GO TO 10 CALL SCDM (U,K,S,C,D) RETURN 10 IF (V .GT. 0.01) GO TO 20 CALL SCDM (V,K,S1,C1,D1) S = C1/D1 C = L*S1/D1 D = L/D1 RETURN C C USES FOURIER EXPANSION WHEN K .LE. L C 20 CALL ELLPI(PIHALF,0.0,L,K,F1,E1,IERR) C IF (K .GT. L) GO TO 30 CALL SCDF (U,K,L,F,F1,S,C,D) RETURN C C USES IMAGINARY TRANSFORMATION OF JACOBI AND FOURIER C EXPANSION WHEN K .GT. L C 30 CALL SCDJ (U,K,L,F,F1,S,C,D) RETURN C C COMPUTATION FOR K = 0.0 C 40 S = SIN(U) C = COS(U) D = 1.0 RETURN END SUBROUTINE SCDM(U,K,S,C,D) C ------------------------------------------------- C CALCULATES SN(U,K), CN(U,K), AND DN(U,K) FOR C 0.0 .LE. U .LE. 0.01 AND FOR 0.0 .LE. K .LE. 1.0 C BY USE OF THE MACLAURIN EXPANSION FOR SN(U,K) C ------------------------------------------------- REAL K, K2 C K2 = K*K U2 = U*U C1 = -(1.0 + K2)/6.0 C2 = (1.0 + K2*(14.0 + K2))/120.0 C3 = -(1.0 + K2*(135.0 + K2*(135.0 + K2)))/5040.0 C4 = (1.0 + K2*(1228.0 + K2*(5478.0 + K2*(1228.0 + K2))))/ * 362880.0 S = U*(1.0 + U2*(C1 + U2*(C2 + U2*(C3 + C4*U2)))) C = SQRT(1.0 - S*S) D = SQRT(1.0 - (K*S)**2) RETURN END SUBROUTINE SCDF(U,K,L,F,F1,S,C,D) C ------------------------------------------------------------- C SCDF COMPUTES SN(U,K), CN(U,K), AND DN(U,K) FOR REAL U AND C K BY USE OF THE FOURIER EXPANSION FOR SN(U,K). IT IS C ASSUMED THAT 0.0 .LE. K .LT. 1.0 AND 0.0 .LE. U .LE. F, C WHERE F = F(K) IS THE COMPLETE ELLIPTIC INTEGRAL OF THE C FIRST KIND AND F1 = F(L) IS THE COMPLEMENTARY INTEGRAL, WITH C L .NE. 0. AND K**2 + L**2 = 1. C ------------------------------------------------------------- REAL I, K, L DATA PIHALF /1.5707963267949/ C ------------------------------------------------- C EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE C SMALLEST NUMBER SUCH THAT 1. + EPS .GT. 1. C EPS = SPMPAR(1) C C ------------------------------------------------- TOL = EPS/10.0 V = F - U QH = EXP(-PIHALF*F1/F) Q1 = QH*QH Q2 = Q1*Q1 COEF = 4.*PIHALF*QH/(K*F) QN = 1.0 QD = Q1 W = AMIN1(U,V) X = PIHALF*W/F C C CALCULATION OF SERIES FOR W = AMIN1(U,V) C I = 1.0 SUM = 0.0 10 AI = QN/(1.0 - QD) A = AI*SIN(I*X) SUM = SUM + A IF (ABS(AI) .LT. TOL*ABS(SUM)) GO TO 20 QN = QN*Q1 QD = QD*Q2 I = I + 2.0 GO TO 10 C C ASSEMBLY FOR U .LE. V C 20 S = COEF*SUM C = SQRT(1.0 - S*S) D = SQRT(1.0 - (K*S)**2) IF (U .EQ. W) RETURN C C ASSEMBLY FOR U .GT. V C TEMP = S S = C/D C = L*TEMP/D D = L/D RETURN END SUBROUTINE SCDJ(U,K,L,F,F1,S,C,D) C ---------------------------------------------------------------- C SCDJ COMPUTES SN(U,K), CN(U,K), AND DN(U,K) FOR REAL U AND C K USING THE IMAGINARY TRANSFORMATION OF JACOBI AND A C FOURIER EXPANSION. IT IS ASSUMED THAT 0.0 .LE. K .LT. 1.0 C AND 0.0 .LE. U .LE. F, WHERE F = F(K) IS THE COMPLETE ELLIPTIC C INTEGRAL OF THE FIRST KIND AND F1 = F(L) IS THE COMPLEMENTARY C INTEGRAL, AND THAT L .NE. 0. AND K**2 + L**2 = 1. C ---------------------------------------------------------------- REAL K, L, N DATA PIHALF /1.5707963267949/ DATA PI /3.1415926535898/ C ------------------------------------------------ C EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE C SMALLEST NUMBER SUCH THAT 1. + EPS .GT. 1. C EPS = SPMPAR(1) C C ------------------------------------------------ TOL = EPS/10.0 V = F - U Q1 = -EXP(-PI*F/F1) Q2 = Q1*Q1 C W = AMIN1(U,V) E1 = PI*AMAX1(U,V)/F1 E2 = PI*(F + W)/F1 E1 = EXP(-E1) E2 = EXP(-E2) C COEF = PIHALF/(K*F1) X = PIHALF*W/F1 X2 = 2.0*X C C CALCULATION OF SERIES FOR W = AMIN1(U,V) C N = 1.0 Q1N = Q1 Q2N = Q2 E1N = E1 E2N = E2 SUM = 0.0 C 20 XN = N*X2 IF (XN .GT. 1.0) GO TO 30 CALL SNHCSH(SH,CH,XN,-1) SH = SH + XN A = 2.0*Q1N*ABS(Q1N)*SH/(1.0 + Q2N) GO TO 40 30 A = Q1N*(E1N - E2N)/(1.0 + Q2N) 40 SUM = SUM + A IF (ABS(A) .LT. TOL*ABS(SUM)) GO TO 50 Q1N = Q1N*Q1 Q2N = Q2N*Q2 E1N = E1N*E1 E2N = E2N*E2 N = N + 1.0 GO TO 20 C C ASSEMBLY FOR U .LE. V C 50 S = COEF*(TANH(X) + 2.0*SUM) C = SQRT(1.0 - S*S) D = SQRT(1.0 - (K*S)**2) IF (U .EQ. W) RETURN C C ASSEMBLY FOR U .GT. V C TEMP = S S = C/D C = L*TEMP/D D = L/D RETURN END SUBROUTINE ELPFC1 (U,K,L,S,C,D,IERR) C ------------------------------------------------------------- C ELPFC1 CALCULATES THE ELLIPTIC FUNCTIONS SN(U,K), CN(U,K), C DN(U,K) FOR COMPLEX U AND REAL MODULUS K. IT IS ASSUMED THAT C ABS(K) .LE. 1. AND K**2 + L**2 = 1. C ------------------------------------------------------------- COMPLEX U, S, C, D REAL K, L, K2 C U1 = REAL(U) U2 = AIMAG(U) K2 = K*K IF (U1 .EQ. 0.0) GO TO 10 IF (U2 .NE. 0.0) GO TO 20 C C CALCULATION FOR U2 = 0. C CALL ELLPF (U1,K,L,S1,C1,D1,IERR) IF (IERR .NE. 0) RETURN S2 = 0.0 C2 = 0.0 D2 = 0.0 GO TO 40 C C CALCULATION FOR U1 = 0. C 10 CALL ELLPF (U2,L,K,S2,C2,D2,IERR) IF (IERR .NE. 0) RETURN IF (C2 .EQ. 0.0) GO TO 50 S1 = 0.0 S2 = S2/C2 D1 = D2/C2 D2 = 0.0 C1 = 1.0/C2 C2 = 0.0 GO TO 40 C C CALCULATION FOR U1 AND U2 .NE. 0. C 20 CALL ELLPF (U1,K,L,SK,CK,DK,IERR) IF (IERR .NE. 0) RETURN CALL ELLPF (U2,L,K,SL,CL,DL,IERR) IF (IERR .NE. 0) RETURN COEF = ABS(K)*SL T1 = CL T2 = COEF*SK TD1 = COEF*T1 TD2 = COEF*T2 IF (ABS(T2) .LE. ABS(T1)) GO TO 30 IF (T2 .EQ. 0.0) GO TO 50 IF (TD2 .EQ. 0.0) GO TO 50 T = T1/T2 R = 1.0/(1.0 + T*T) S1 = DL*R/TD2 S2 = CK*DK*SL*T*R/T2 C1 = CK*T*R/T2 C2 = -DK*SL*DL*R/TD2 D1 = DK*DL*T*R/T2 D2 = -K2*CK*SL*R/TD2 GO TO 40 30 IF (T1 .EQ. 0.0) GO TO 50 IF (TD1 .EQ. 0.0) GO TO 50 T = T2/T1 R = 1.0/(1.0 + T*T) S1 = DL*T*R/TD1 S2 = CK*DK*SL*R/T1 C1 = CK*R/T1 C2 = -DK*SL*DL*T*R/TD1 D1 = DK*DL*R/T1 D2 = -K2*CK*SL*T*R/TD1 C C FINAL ASSEMBLY C 40 S = CMPLX (S1, S2) C = CMPLX (C1, C2) D = CMPLX (D1, D2) RETURN C C ERROR RETURN C 50 IERR = 3 RETURN END SUBROUTINE PEQ(Z, W, IERR) C C WEIERSTRASS P-FUNCTION IN THE EQUIANHARMONIC CASE C FOR COMPLEX ARGUMENT WITH UNIT PERIOD PARALLELOGRAM C COMPLEX Z, Z1, Z4, Z6, W REAL ZR, ZI INTEGER IERR, M, N C C REDUCTION TO FUNDAMENTAL PARALLELOGRAM C ZI = 1.1547005383792515E0*AIMAG(Z) + 0.5E0 M = INT(ZI) IF (ZI.LT.0E0) M = M - 1 ZR = REAL(Z) - 0.5E0*FLOAT(M) + 0.5E0 N = INT(ZR) IF (ZR.LT.0E0) N = N - 1 Z1 = Z - FLOAT(N) - (0.5E0,0.86602540378443865E0)*FLOAT(M) C C IF Z1=0 THEN Z COINCIDES WITH A LATTICE POINT. C THE LATTICE POINTS ARE POLES FOR P. C W = Z1*Z1 ZR = ABS(REAL(W)) + ABS(AIMAG(W)) IF (ZR.NE.0E0) GO TO 10 IERR = 1 RETURN C C EVALUATION OF P(Z1) C 10 IERR = 0 Z4 = W*W Z6 = Z4*W W = 1E0/W + 6E0*Z4*(5E0+Z6)/(1E0-Z6)**2 + Z4* * (((((-2.6427662E-10*Z6+1.610954818E-8)*Z6+7.38610752879E-6)* * Z6+4.3991444671178E-4)*Z6+7.477288220490697E-2)* * Z6-6.8484153287299201E-1)/(((((6.2252191E-10*Z6+2.553314573E-7)* * Z6-2.619832920421E-5)*Z6-5.6444801847646E-4)* * Z6+4.565553484820106E-2)*Z6+1E0) RETURN END SUBROUTINE PEQ1(Z, W, IERR) C C FIRST DERIVATIVE OF WEIERSTRASS P-FUNCTION IN THE C EQUIANHARMONIC CASE FOR COMPLEX ARGUMENT C WITH UNIT PERIOD PARALLELOGRAM C COMPLEX Z, Z1, Z3, Z6, W REAL ZR, ZI INTEGER IERR, M, N C C REDUCTION TO FUNDAMENTAL PARALLELOGRAM C ZI = 1.1547005383792515E0*AIMAG(Z) + 0.5E0 M = INT(ZI) IF (ZI.LT.0E0) M = M - 1 ZR = REAL(Z) - 0.5E0*FLOAT(M) + 0.5E0 N = INT(ZR) IF (ZR.LT.0E0) N = N - 1 Z1 = Z - FLOAT(N) - (0.5E0,0.86602540378443865E0)*FLOAT(M) C C IF Z1=0 THEN Z COINCIDES WITH A LATTICE POINT. C THE LATTICE POINTS ARE POLES FOR DP. C Z3 = Z1*Z1*Z1 Z6 = Z3*Z3 W = Z3*(1E0-Z6)**3 ZR = ABS(REAL(W)) + ABS(AIMAG(W)) IF (ZR.NE.0E0) GO TO 10 IERR = 1 RETURN C C EVALUATION OF DP(Z1) C 10 IERR = 0 W = (((14E0*Z6+294E0)*Z6+126E0)*Z6-2E0)/W + * Z3*((((((-2.95539175E-9*Z6-2.6764693031E-7)*Z6+2.402192743346E-5) * *Z6+1.9656661451391E-4)*Z6+1.760135529461036E-2)* * Z6+8.1026243498822636E-1)*Z6-2.73936613149196804E0)/ * ((((((4.6397763E-10*Z6+5.413482233E-8)*Z6-1.56293298374E-6)* * Z6-1.0393701076352E-4)*Z6+9.5553182532237E-4)* * Z6+9.131106969640212E-2)*Z6+1E0) RETURN END SUBROUTINE PLEM(Z, W, IERR) C C WEIERSTRASS P-FUNCTION IN THE LEMNISCATIC CASE C FOR COMPLEX ARGUMENT WITH UNIT PERIOD PARALLELOGRAM C COMPLEX Z, Z1, Z4, Z6, W REAL ZR, ZI INTEGER IERR, M, N C C REDUCTION TO FUNDAMENTAL PARALLELOGRAM C ZR = REAL(Z) + 0.5E0 ZI = AIMAG(Z) + 0.5E0 M = INT(ZR) N = INT(ZI) IF (ZR.LT.0E0) M = M - 1 IF (ZI.LT.0E0) N = N - 1 Z1 = Z - FLOAT(M) - (0E0,1E0)*FLOAT(N) C C IF Z1=0 THEN Z COINCIDES WITH A LATTICE POINT. C THE LATTICE POINTS ARE POLES FOR P. C W = Z1*Z1 ZR = ABS(REAL(W)) + ABS(AIMAG(W)) IF (ZR.NE.0E0) GO TO 10 IERR = 1 RETURN C C EVALUATION OF P(Z1) C 10 IERR = 0 Z4 = W*W Z6 = Z4*W W = 1E0/W + 4E0*W*(3E0+Z4)/(1E0-Z4)**2 + * W*((((((((-7.233108E-11*Z4+1.714197273E-8)*Z4-2.5369036492E-7)* * Z4-7.98710206868E-6)*Z4+6.4850606909737E-4)*Z4+7.39624629362938E- * 3)*Z4+2.012382768497244E-2)*Z4+7.1177297543136598E-1)* * Z4-2.54636399353830738E0)/((((((((5.1161516E-10*Z4+6.61289408E-9) * *Z4+4.4618987048E-7)*Z4-8.42694918892E-6)*Z4+4.42886829095E-6)* * Z4-4.22629935217101E-3)*Z4+2.577496871700433E-2)* * Z4+4.2359940482277074E-1)*Z4+1E0) RETURN END SUBROUTINE PLEM1(Z, W, IERR) C C FIRST DERIVATIVE OF WEIERSTRASS P-FUNCTION IN THE C LEMNISCATIC CASE FOR COMPLEX ARGUMENT C WITH UNIT PERIOD PARALLELOGRAM C COMPLEX Z, Z1, Z3, Z4, W REAL ZR, ZI INTEGER IERR, M, N C C REDUCTION TO FUNDAMENTAL PARALLELOGRAM C ZR = REAL(Z) + 0.5E0 ZI = AIMAG(Z) + 0.5E0 M = INT(ZR) N = INT(ZI) IF (ZR.LT.0E0) M = M - 1 IF (ZI.LT.0E0) N = N - 1 Z1 = Z - FLOAT(M) - (0E0,1E0)*FLOAT(N) C C IF Z1=0 THEN Z COINCIDES WITH A LATTICE POINT. C THE LATTICE POINTS ARE POLES FOR DP. C Z3 = Z1*Z1*Z1 Z4 = Z3*Z1 W = (Z1*(1E0-Z4))**3 ZR = ABS(REAL(W)) + ABS(AIMAG(W)) IF (ZR.NE.0E0) GO TO 10 IERR = 1 RETURN C C EVALUATION OF DP(Z1) C 10 IERR = 0 W = (((1E1*Z4+9E1)*Z4+3E1)*Z4-2E0)/W + * Z1*((((((((((-3.9046302E-9*Z4-1.001487137E-8)*Z4+5.9573043092E-7) * *Z4-2.482518130524E-5)*Z4+1.4557266595395E-4)* * Z4+4.56633655643206E-3)*Z4+6.224782572111135E-2)* * Z4+1.038527937794269E-2)*Z4+1.19804620802637942E0)* * Z4+6.42791439683811718E0)*Z4-5.09272798707661477E0)/ * ((((((((((4.726888E-11*Z4-3.0667983E-9)*Z4+1.0087596089E-7)* * Z4-8.060683451E-8)*Z4+1.184299251664E-5)*Z4-2.3096723361547E-4)* * Z4-2.90730903142055E-3)*Z4+1.338392411135511E-2)* * Z4+2.3098639320021426E-1)*Z4+8.4719880964554148E-1)*Z4+1E0) RETURN END SUBROUTINE VALR2(X,Y,N0,P,IOP,A,IND,KO) C ------------------- DIMENSION X(*),Y(*),G(2),H(2) DIMENSION E(5),E2(10),E3(15) DIMENSION APH1(3),APH2(3),APH4(3) DIMENSION RSQ(3),A3D8(3),CST(3) REAL KOM,L C ------------------- DATA PI/3.1415926535898/ DATA TWOPI/6.28318530717958/ DATA ALNPI/1.14472988584940/ DATA RTPI/1.77245385090552/ DATA RTPII/.56418958354776/ C ------------------- DATA E(1)/.885777518572895E+00/, E(2)/-.981151952778050E+00/, 1 E(3)/.759305502082485E+00/, E(4)/-.353644980686977E+00/, 2 E(5)/.695232092435207E-01/ DATA E2(1) /.886226470016632E+00/, E2(2) /-.999950714561036E+00/, 1 E2(3) /.885348820003892E+00/, E2(4) /-.660611239043357E+00/, 2 E2(5) /.421821197160099E+00/, E2(6) /-.222898055667208E+00/, 3 E2(7) /.905057384150449E-01/, E2(8) /-.254906111884287E-01/, 4 E2(9) /.430895168984138E-02/, E2(10)/-.323377239693247E-03/ DATA E3(1) /.886226924931465E+00/, E3(2) /-.999999899776252E+00/, 1 E3(3) /.886223733186722E+00/, E3(4) /-.666626670510907E+00/, 2 E3(5) /.442851899328569E+00/, E3(6) /-.265638206366025E+00/, 3 E3(7) /.145060043403014E+00/, E3(8) /-.714909837799889E-01/, 4 E3(9) /.309199295521210E-01/, E3(10)/-.112323532148441E-01/, 5 E3(11)/.324944543171185E-02/, E3(12)/-.704260243309096E-03/, 6 E3(13)/.105787574480633E-03/, E3(14)/-.971864864160461E-05/, 7 E3(15)/.408335517232165E-06/ DATA APH1(1)/2.02E-7/, APH1(2)/2.08E-13/, APH1(3)/2.71E-19/ DATA APH2(1)/1.22E-2/, APH2(2)/1.23E-4/, APH2(3)/1.34E-6/ DATA APH4(1)/.6962E-1/, APH4(2)/.6990E-2/, APH4(3)/.7311E-3/ DATA RSQ(1)/6.0516/, RSQ(2)/12.60605/, RSQ(3)/19.201924/ DATA A3D8(1)/0.28125E-4/, A3D8(2)/0.285E-7/, A3D8(3)/0.32625E-10/ DATA CST(1)/.5625E-4/, CST(2)/.57E-7/, CST(3)/.6512E-10/ C ------------------- C TAU IS A MACHINE DEPENDENT TOLERANCE. IT IS ASSUMED THAT A C 7 OR MORE DIGIT FLOATING POINT ARITHMETIC IS BEING USED. C ------------------- TAU=2.0*SPMPAR(1) IF (TAU.LT.3.E-11) TAU=AMAX1(5.0*TAU,1.E-14) C ------------------- N=N0 IF (N.EQ.2.OR.N.LT.1) GO TO 4021 TAUSQ=TAU*TAU C P=0.0 IND=0 A=0.0 KOM=0.0 K=1 IF (N.NE.1) GO TO 10 C W=X(2)-X(1) Z=Y(2)-Y(1) U=X(3)-X(1) V=Y(3)-Y(1) XK=0.0 PSI1=V*W-U*Z IF (PSI1.GE.0.0) GO TO 21 C P=-1.0 T1=W W=U U=T1 T1=V V=Z Z=T1 GO TO 21 C 10 KO=0 X(N+1)=X(1) Y(N+1)=Y(1) U=X(2)-X(1) V=Y(2)-Y(1) XK=X(1) YK=Y(1) C 20 W=X(1)-X(N) Z=Y(1)-Y(N) 21 D1SQ=W*W+Z*Z IF (D1SQ.GT.TAUSQ) GO TO 30 IF (N.EQ.1) GO TO 4011 N=N-1 IF (N.EQ.2) RETURN GO TO 20 C 30 D2SQ=U*U+V*V IF (D2SQ.GT.TAUSQ) GO TO 40 IF (N.EQ.1) GO TO 4011 31 K=K+1 U=X(K+1)-XK V=Y(K+1)-YK D2SQ=U*U+V*V IF (D2SQ.LE.TAUSQ) GO TO 31 IF (K.EQ.N-1) RETURN C 40 A=XK*(Y(K+1)-Y(N)) BGD1=SQRT(D1SQ+D1SQ) BGD2=SQRT(D2SQ+D2SQ) C C PROCESSING VERTEX (XK,YK) C 50 PSI1=V*W-U*Z CEE=U*W+V*Z AJ0=ATAN2(PSI1,CEE) KOM=KOM+AJ0 L=0.0 B=.5*(X(K)*X(K)+Y(K)*Y(K)) IF (B.GT.APH1(IOP)) GO TO 60 P1=AJ0/TWOPI GO TO 3621 C 60 G(1)=(W*X(K)+Z*Y(K))/BGD1 G(2)=(U*X(K)+V*Y(K))/BGD2 H(1)=(-Y(K)*W+X(K)*Z)/BGD1 H(2)=(-Y(K)*U+X(K)*V)/BGD2 IF (ABS(PSI1).GT.BGD1*BGD2*A3D8(IOP)) GO TO 80 IF (CEE.LT.0.0) GO TO 70 IF (ABS(AJ0).GT.TAU.AND.G(1).LT.0.0) GO TO 80 P1=0.0 GO TO 3621 C 70 IF (ABS(PSI1).LE.(.5*TAU*BGD1*BGD2)) IND=2 IF (PSI1.LT.0.0) GO TO 71 P1=.5*ERFC1(0,H(2)) GO TO 3621 71 P1=-.5*ERFC1(0,H(1)) GO TO 3621 C 80 IF (B.GT.APH2(IOP)) GO TO 90 C=RTPI*(H(2)-H(1))-(G(2)*H(2)-G(1)*H(1)) P1=(AJ0-C)/TWOPI GO TO 3621 C C COMPUTATION OF L C 90 IF (G(1).LT.0.0) GO TO 100 IF (G(2).GE.0.0) GO TO 130 G(2)=-G(2) H(2)=-H(2) IF (ABS(H(2)).LE.APH4(IOP)) GO TO 91 L=.5*ERFC1(0,-H(2)) GO TO 120 91 L=.5+RTPII*H(2) GO TO 120 C 100 G(1)=-G(1) H(1)=-H(1) IF (G(2).LT.0.0) GO TO 110 IF (ABS(H(1)).LE.APH4(IOP)) GO TO 101 L=.5*ERFC1(0,H(1)) GO TO 120 101 L=.5-RTPII*H(1) GO TO 120 C 110 G(2)=-G(2) H(2)=-H(2) IF (ABS(H(1)).LE.APH4(IOP)) GO TO 112 IF (ABS(H(2)).LE.APH4(IOP)) GO TO 111 L=.5*(ERFC1(0,H(1))-ERFC1(0,H(2))) GO TO 130 111 L=RTPII*H(2)-.5*ERF(H(1)) GO TO 130 112 IF (ABS(H(2)).LE.APH4(IOP)) GO TO 113 L=.5*ERF(H(2))-RTPII*H(1) GO TO 130 113 L=RTPII*(H(2)-H(1)) GO TO 130 C 120 PSI1=-PSI1 IF (PSI1.LE.0.0) GO TO 121 L=L-1.0 AJ0=AJ0+PI GO TO 130 121 AJ0=AJ0-PI C C SERIES EVALUATION C 130 IF (B.GE.RSQ(IOP)) GO TO 171 CAPE=AJ0 CAPH=.5*AJ0 M=1 F=0.0 AJ1=H(2)-H(1) CIRCM=AJ1 IF (IOP-2) 140,150,160 C 140 SUM=E(M)*AJ1 141 M=M+1 H(1)=H(1)*G(1) H(2)=H(2)*G(2) T=H(2)-H(1) F=F+B CAPV=(F*CAPE+T)/M SUM=SUM+E(M)*CAPV IF (M.GE.5) GO TO 170 CAPE=CIRCM CIRCM=CAPV GO TO 141 C 150 SUM=E2(M)*AJ1 151 M=M+1 H(1)=H(1)*G(1) H(2)=H(2)*G(2) T=H(2)-H(1) F=F+B CAPV=(F*CAPE+T)/M SUM=SUM+E2(M)*CAPV IF (M.GE.10) GO TO 170 CAPE=CIRCM CIRCM=CAPV GO TO 151 C 160 SUM=E3(M)*AJ1 161 M=M+1 H(1)=H(1)*G(1) H(2)=H(2)*G(2) T=H(2)-H(1) F=F+B CAPV=(F*CAPE+T)/M SUM=SUM+E3(M)*CAPV IF (M.GE.15) GO TO 170 CAPE=CIRCM CIRCM=CAPV GO TO 161 C 170 P1=L+EXP(-(B+ALNPI))*(CAPH-SUM) GO TO 3621 171 P1=L C C STANDARD TERMINATION C 3621 IF (K.NE.N) GO TO 3651 IF (N.NE.1) GO TO 3631 P=ABS(P+ABS(P1)) RETURN C 3631 P=P-P1 KOM=KOM/TWOPI A=.5*A IF (KOM.LT.0.0) GO TO 3641 KO=INT(KOM+.125) GO TO 3645 3641 KO=INT(KOM-.125) 3645 P=P+FLOAT(KO) RETURN C C SET UP THE NEXT VERTEX C 3651 W=U Z=V BGD1=BGD2 XK=X(K+1) YK=Y(K+1) YKM1=Y(K) 3661 K=K+1 U=X(K+1)-XK V=Y(K+1)-YK D2SQ=U*U+V*V IF (D2SQ.LE.TAUSQ) GO TO 3661 BGD2=SQRT(D2SQ+D2SQ) P=P-P1 A=A+XK*(Y(K+1)-YKM1) GO TO 50 C C ERROR RETURN C 4011 IND=1 P=5.0 RETURN 4021 IND=3 RETURN END SUBROUTINE CIRCV (R, D, J, P, IERR) C----------------------------------------------------------------------- C IF J .NE. 0, OUTPUT IS P = CIRCULAR COVERAGE FUNCTION. P GIVES C THE PROBABILITY OF A SHOT FALLING, UNDER A NORMAL DISTRIBUTION C WITH MEAN (0,0) AND EQUAL STANDARD DEVIATIONS, S, IN A CIRCLE C OF RADIUS R0, OFFSET A DISTANCE D0 FROM (0,0). C INPUT IS R = R0/S, D = D0/S. C C IF J = 0, OUTPUT IS P = GENERALIZED CIRCULAR ERROR FUNCTION. C P GIVES THE PROBABILITY OF A SHOT FALLING ,UNDER A NORMAL C BIVARIATE DISTRIBUTION WITH MEAN (0,0) AND STANDARD DEVIATIONS C SMIN AND S, IN A CIRCLE OF RADIUS R0 CENTERED AT (0,0). C INPUT FOR J = 0, R = R0/S, D = SMIN/S .LE. 1. C IF SMIN = 0, S .NE. 0, P = ERF(R/(SQR(2)). C C IF IERR .NE. 0, SOME PORTION OF THE INPUT IS UNACCEPTABLE. C IF R .LT. 0., THEN CIRCV SETS IERR = 1. C IF D .LT. 0, OR J = 0 AND D .GT. 1., THEN CIRCV SETS IERR = 2. C C REFERENCES C MATH OF COMP APRIL 1961,PP169,173 AND OCT.1961, PP 375, 382. C NWL REPORT N0.1768, JAN. 1962. NSWC REPORT N0.83-13, NOV. 1982. C IEEE TRANS. INFO. TH. APRIL 1965, P. 312. C----------------------------------------------------------------------- C NEGATIVE R AND D ARE NOT PERMITTED. C-------------------------------------------- REAL M, M0 C----------------------- C C1 = 1/SQRT(2) C C2 = 1/SQRT(PI) C C3 = 2*PI C----------------------- DATA E /2.71828182845905/ DATA C1 /.707106781186548/ DATA C2 /.564189583547756/ DATA C3 /6.28318530717959/ C----------------------- P = 0.0 IF (R .LT. 0.0) GOTO 115 IF (D .LT. 0.0) GOTO 120 IERR = 0 IF (R .EQ. 0.0) RETURN C EPS0 = SPMPAR(1) Z = - ALOG(EPS0) IF (J .NE. 0) GOTO 40 C------------------------------------------------------------------ C FOR J = 0, ERROR IN D IF D .LT. 0 OR D .GT. 1 C------------------------------------------------------------------ C J = 0 C-------------------------------------------------- IF (D .GT. 1.0) GOTO 120 IF (D .EQ. 1.0) GOTO 45 IF (D .NE. 0.0) GOTO 5 C--------------------------------------- C J = 0, D = 0 C--------------------------------------- P = ERF(R*C1) RETURN C------------------------------------------------- C J = 0, (R*R .GT. -2*LOG(EPS0)) P = 1 C------------------------------------------------- 5 IF (R*R .LT. 2.0*Z) GOTO 10 P = 1.0 RETURN C--------------------------------------------- 10 X = R D2 = D*D Y1 = R/D T = 0.5*Y1 ZM = (0.5 - D2) + 0.5 T2 = T*T T = T2*ZM C EPS = 10.0*EPS0 IF (T .GT. 14.0) GO TO 25 C------------------------------------------------- C J = 0, T .LE. 14 C------------------------------------------------- ZP = 1.0 + D2 ZR = ZM/ZP ZRS = ZR*ZR BK2 = T2*ZP C0 = 2.0*D/ZP S0 = EXP(-BK2) T0 = 0.5 + (0.5 - S0) IF (BK2 .LE. 0.15) T0 = -REXP(-BK2) T0 = C0*T0 S0 = C0*S0 C P = T0 AN = 0.0 20 AN = AN + 2.0 F = (AN - 1.0)/AN W = T/AN X = S0*W T0 = F*ZRS*T0 - (W + ZR)*X S0 = W*X P = P + T0 IF (T0 .GT. EPS*P) GO TO 20 RETURN C------------------------------------------------ C J = 0, T .GT. 14 C------------------------------------------------ 25 T = 0.25/T CONST = D2/ZM DELTA = SQRT(ZM) X = 2.0*(C1*C2)/(R*DELTA) EXPT = EXP(-0.5*R*R) CALL ERFC0 (1, C1*R, EXPT, M) M = M/DELTA C P = 1.0 SUM = M AN = 0.0 IF (EXPT*M .LT. 5.E-3) GO TO 30 C C SET P = 1 - EXP(-R*R/2)*M C P = (ERF(C1*R) - D2/(1.0 + DELTA))/DELTA SUM = 0.0 C C COMPUTE THE ASYMPTOTIC EXPANSION C 30 AN = AN + 2.0 ANM1 = AN - 1.0 F = ANM1/AN M0 = M M = CONST*F*(X - M) IF (M .GE. M0 .OR. M .LT. 0.0) GO TO 35 X = ANM1*F*T*X SUM = SUM + M IF (M .GT. EPS*SUM) GO TO 30 35 P = P - EXPT*SUM GO TO 110 C------------------------------------ C J .NE. 0 C------------------------------------ 40 A1 = R - D T = R*D IF (D .NE. 0.0) GO TO 50 C---------------------------------------------- C J = 0 AND D = 1, OR J .NE. 0 AND D = 0 C---------------------------------------------- 45 P = -REXP(-0.5*R*R) RETURN C---------------------------------------- 50 A = 0.5*(A1*A1) IF (A1 .LE. 5.0) GO TO 55 IF (A .LE. Z) GO TO 60 P = 1.0 RETURN 55 IF (A1 .LT. -5.0 .AND. A .GT. -EXPARG(1)) RETURN C---------------------------------------- 60 EPS = 1.5E2*EPS0 IF (R .GE. 1.7 .AND. T .GT. 16.0) GO TO 75 C------------------------------------------------------------------ C J .NE. 0, R .LT. 1.7 OR R*D .LE. 16 C------------------------------------------------------------------ TR = 0.5*(R*R) TD = 0.5*(D*D) C C FIND THE NUMBER N OF TERMS TO BE USED IN THE SERIES C Z = 0.5*T N = Z*E + 1.0 TN = ((E*Z/N)**(N + N))/(C3*N) 65 N = N + 1 W = Z/N TN = TN*(W*W) IF (TN .GT. EPS) GO TO 65 C C COMPUTE THE SERIES C M = N CALL GRATIO (M + 1.0, TR, S, W, 0) W = RCOMP(M,TR)/M P = S DO 70 I = 1,N S = S + W W = (M/TR)*W P = S + (TD/M)*P 70 M = M - 1.0 P = EXP(-TD)*P GO TO 110 C------------------------------------------------------------------ C J .NE. 0, R .GE. 1.7 AND R*D .GT. 16 C------------------------------------------------------------------ 75 Z = C1*ABS(A1) W = EXP(-A) CALL ERFC0 (1, Z, W, S1) C A = 0.5*Z/T T = 0.25/T M = C2 - Z*S1 IF (Z .GE. 4.0) M = ERFCR(Z) M = 0.5*A*M X = 0.5*C2*T S1 = S1 + M S2 = C2 + X C AN = 2.0 80 AN = AN + 2.0 ANM1 = AN - 1.0 F = ANM1/AN M0 = M M = F*A*(X - Z*M) X = F*(ANM1*T)*X S2 = S2 + X IF (M .LE. 0.0 .OR. M .GE. M0) GO TO 90 S1 = S1 + M IF (M .GT. EPS*S1) GO TO 80 C 90 AN = AN + 2.0 ANM1 = AN - 1.0 X0 = X X = (ANM1/AN)*(ANM1*T)*X IF (X .GE. X0) GO TO 100 S2 = S2 + X IF (X .GT. EPS*S2) GO TO 90 C 100 S1 = 0.5*(R + D)*S1 S2 = C1*S2 W = W/SQRT(R*D) P = 0.5*W*ABS(S1 - S2) IF (A1 .GT. 0.0) P = ABS(1.0 - 0.5*W*(S1 + S2)) C C TERMINATION C 110 IF (P .GT. 1.0) P = 1.0 RETURN 115 IERR = 1 P = -1.0 RETURN 120 IERR = 2 P = -1.0 RETURN END SUBROUTINE ERFC0 (IND, X, E, Y) C----------------------------------------------------------------------- C EVALUATION OF THE COMPLEMENTARY ERROR FUNCTION C C Y = ERFC(X) IF IND = 0 C Y = EXP(X*X)*ERFC(X) OTHERWISE C C E IS AN INPUT/OUTPUT VARIABLE. IF E .GE. 0 THEN IT IS ASSUMED C THAT E = EXP(-X*X). IN THIS CASE E IS NOT MODIFIED. IF E IS C NEGATIVE THEN E IS SET TO EXP(-X*X) WHEN THIS VALUE IS NEEDED. C C----------------------------------------------------------------------- REAL A(4),B(4),P(8),Q(8),R(5),S(5) DOUBLE PRECISION W C------------------------- DATA C/.564189583547756/ C------------------------- DATA A(1)/-1.65581836870402E-4/, A(2)/3.25324098357738E-2/, * A(3)/1.02201136918406E-1/, A(4)/1.12837916709552E00/ DATA B(1)/4.64988945913179E-3/, B(2)/7.01333417158511E-2/, * B(3)/4.23906732683201E-1/, B(4)/1.00000000000000E00/ DATA P(1)/-1.36864857382717E-7/, P(2)/5.64195517478974E-1/, * P(3)/7.21175825088309E00/, P(4)/4.31622272220567E01/, * P(5)/1.52989285046940E02/, P(6)/3.39320816734344E02/, * P(7)/4.51918953711873E02/, P(8)/3.00459261020162E02/ DATA Q(1)/1.00000000000000E00/, Q(2)/1.27827273196294E01/, * Q(3)/7.70001529352295E01/, Q(4)/2.77585444743988E02/, * Q(5)/6.38980264465631E02/, Q(6)/9.31354094850610E02/, * Q(7)/7.90950925327898E02/, Q(8)/3.00459260956983E02/ DATA R(1)/2.10144126479064E00/, R(2)/2.62370141675169E01/, * R(3)/2.13688200555087E01/, R(4)/4.65807828718470E00/, * R(5)/2.82094791773523E-1/ DATA S(1)/9.41537750555460E01/, S(2)/1.87114811799590E02/, * S(3)/9.90191814623914E01/, S(4)/1.80124575948747E01/, * S(5)/1.00000000000000E00/ C------------------------- C C ABS(X) .LT. 0.47 C AX = ABS(X) IF (AX .GE. 0.47) GO TO 10 T = X*X TOP = ((A(1)*T + A(2))*T + A(3))*T + A(4) BOT = ((B(1)*T + B(2))*T + B(3))*T + B(4) Y = 0.5 + (0.5 - X*TOP/BOT) IF (IND .EQ. 0) RETURN C IF (E .LT. 0.0) E = EXP(-T) Y = Y/E RETURN C C 0.47 .LE. ABS(X) .LE. 4 C 10 IF (AX .GT. 4.0) GO TO 30 TOP = ((((((P(1)*AX + P(2))*AX + P(3))*AX + P(4))*AX + P(5))*AX * + P(6))*AX + P(7))*AX + P(8) BOT = ((((((Q(1)*AX + Q(2))*AX + Q(3))*AX + Q(4))*AX + Q(5))*AX * + Q(6))*AX + Q(7))*AX + Q(8) Y = TOP/BOT C 20 IF (IND .EQ. 0) GO TO 21 IF (X .GE. 0.0) RETURN IF (E .LT. 0.0) E = EXP(-X*X) Y = 2.0/E - Y RETURN 21 W = DBLE(X)*DBLE(X) T = W EPS = W - DBLE(T) IF (E .LT. 0.0) E = EXP(-T) Y = ((0.5 + (0.5 - EPS)) * E) * Y IF (X .LT. 0.0) Y = 2.0 - Y RETURN C C ABS(X) .GT. 4 C 30 IF (X .LE. -5.5) GO TO 40 IF (IND .EQ. 0 .AND. X .GT. 50.0) GO TO 50 T = (1.0/X)**2 TOP = (((R(1)*T + R(2))*T + R(3))*T + R(4))*T + R(5) BOT = (((S(1)*T + S(2))*T + S(3))*T + S(4))*T + S(5) Y = (C - T*TOP/BOT) / AX GO TO 20 C C LIMIT VALUE FOR LARGE NEGATIVE X C 40 Y = 2.0 IF (IND .EQ. 0) RETURN IF (E .LT. 0.0) E = EXP(-X*X) Y = 2.0/E RETURN C C LIMIT VALUE FOR LARGE POSITIVE X C WHEN IND = 0 C 50 Y = 0.0 RETURN END REAL FUNCTION ERFCR (X) C----------------------------------------------------------------------- C COMPUTATION OF 1/SQRT(PI) - X*EXP(X*X)*ERFC(X) FOR X .GE. 4 C----------------------------------------------------------------------- REAL R(5), S(4) C------------------------ DATA R(1)/2.10144126479064E+00/, R(2)/2.62370141675169E+01/, * R(3)/2.13688200555087E+01/, R(4)/4.65807828718470E+00/, * R(5)/2.82094791773523E-01/ DATA S(1)/9.41537750555460E+01/, S(2)/1.87114811799590E+02/, * S(3)/9.90191814623914E+01/, S(4)/1.80124575948747E+01/ C------------------------ T = (1.0/X)**2 TOP = (((R(1)*T + R(2))*T + R(3))*T + R(4))*T + R(5) BOT = (((S(1)*T + S(2))*T + S(3))*T + S(4))*T + 1.0 ERFCR = T*TOP/BOT RETURN END SUBROUTINE PKILL (R0, SX, SY, H, K, P) C----------------------------------------------------------------------- C C COMPUTATION OF THE ELLIPTICAL COVERAGE FUNCTION C C --------------- C C THE RESULT P IS ACCURATE TO AT LEAST 6 SIGNIFICANT DIGITS IF C P .GE. 1.E-20 AND MAX(H/S,K/S,SX/S,SY/S) .LE. 10/SQRT(SPMPAR(1)) C FOR S = MIN(SX,SY). C C----------------------------------------------------------------------- REAL K, K8, V(16), W(16) C----------------------------------------------------------------------- C V(*), W(*)-- GAUSSIAN ABSCISSAS AND WEIGHTS OF ORDER 32, ON (-1,1). C----------------------------------------------------------------------- DATA V(1) /.4830766568773832E-01/, V(2) /.1444719615827965E+00/, * V(3) /.2392873622521371E+00/, V(4) /.3318686022821276E+00/, * V(5) /.4213512761306353E+00/, V(6) /.5068999089322294E+00/, * V(7) /.5877157572407623E+00/, V(8) /.6630442669302152E+00/, * V(9) /.7321821187402897E+00/, V(10) /.7944837959679424E+00/, * V(11) /.8493676137325700E+00/, V(12) /.8963211557660521E+00/, * V(13) /.9349060759377397E+00/, V(14) /.9647622555875064E+00/, * V(15) /.9856115115452683E+00/, V(16) /.9972638618494816E+00/ DATA W(1) /.9654008851472780E-01/, W(2) /.9563872007927486E-01/, * W(3) /.9384439908080457E-01/, W(4) /.9117387869576388E-01/, * W(5) /.8765209300440381E-01/, W(6) /.8331192422694676E-01/, * W(7) /.7819389578707031E-01/, W(8) /.7234579410884851E-01/, * W(9) /.6582222277636185E-01/, W(10) /.5868409347853555E-01/, * W(11) /.5099805926237618E-01/, W(12) /.4283589802222668E-01/, * W(13) /.3427386291302143E-01/, W(14) /.2539206530926206E-01/, * W(15) /.1627439473090567E-01/, W(16) /.7018610009470097E-02/ C---------------------------------------- C C = (2**.25)*GAMMA(3/4)/PI C RPI = 1/SQRT(PI) C RT2 = SQRT(2) C---------------------------------------- DATA A3 /20.0/ DATA C /.4638648042895004/ DATA RPI /.5641895835477563/ DATA RT2 /1.414213562373095/ C P = 0.0 IF (SX .GT. 0.0 .AND. SY .GT. 0.0) GO TO 5 P = -1.E10 RETURN 5 J = 0 EPS = SPMPAR(1) SQEPS = SQRT(EPS) A = 6.5 C---------------------------------------- C TEST NO.1 (REPORT 83-13). C---------------------------------------- Z3 = AMIN1(SQRT(SQRT(SPMPAR(2))),1.E-30)*SX*SY IF (R0*R0 .LE. Z3) RETURN C H2 = H*H + K*K H8 = ABS(H) K8 = ABS(K) DM = AMAX1(SX,SY) C----------------------------------------- C TEST NO.2 (REPORT 83-13). C----------------------------------------- IF ((R0 - H8 + A3*SX) .LE. 0.0) RETURN IF ((R0 - K8 + A3*SY) .LE. 0.0) RETURN C----------------------------------------- C TEST NO.3 (REPORT 83-13). C----------------------------------------- C8 = - EPSLN(0) C-----------EXP(-10.3026) = 3.35E(-5)--------- A4 = AMAX1(C8 - 1.74249E1, 10.3026) A4 = SQRT(A4 + A4) H3 = (R0 - H)*(R0 + H) H5 = (R0 - K)*(R0 + K) S0 = A4*DM T = R0 - S0 IF (T .LT. 0.0) GO TO 25 IF (T*T .LT. H2) GO TO 25 IF (R0 .LT. 1/SQEPS) GO TO 20 T = H3 -2.0*R0*S0 + S0*S0 - K*K IF (ABS(H3) .LE. ABS(H5)) GO TO 10 T = H5 - 2.0*R0*S0 + S0*S0 - H*H 10 IF (T .LT. 0.0) GO TO 25 20 P = 1.0 RETURN C----------------------------------------- C TEST NO.4 (REPORT 83-13). C----------------------------------------- 25 S0 = SQRT(H2) G2 = 0.0 IF (S0 .LE. R0) GO TO 30 D = ((S0 - R0)/DM)**2 IF (R0*R0*EXP(-0.5*D) .LE. Z3) RETURN C----------------------------------------- C SX - SY .LT. EPS C----------------------------------------- 30 IF (ABS(SX - SY) .GT. 20.0*DM*EPS) GO TO 33 H8 = S0 K8 = 0.0 IF ((R0 - H8 + A3*DM) .LE. 0.0) RETURN IF (R0 .LT. DM/SQEPS) GO TO 33 J = 1 G2 = (K*K - H3)/((R0 + H8)*DM) IF (ABS(H3) .LE. ABS(H5)) GO TO 33 G2 = (H*H - H5)/((R0 + H8)*DM) C-------------------------- C SMALL R C-------------------------- 33 T1 = R0/SX T2 = R0/SY T3 = T1*T2 T1 = T1*T1 T2 = T2*T2 Z1 = (H/SX)**2 Z2 = (K/SY)**2 T = T1*(Z1 - 1.0) + T2*(Z2 - 1.0) IF (ABS(T) .GT. 1.E-3) GO TO 35 T9 = (T*T - 4.0*(T1*T1*(Z1 - 0.5) + T2*T2*(Z2 - 0.5)))/192.0 IF (ABS(T9) .GT. AMAX1(10.0*EPS,1.E-10)) GO TO 35 P = 0.5*T3*(1.0 + 0.125*T)*EXP(-0.5*(Z1 + Z2)) RETURN C----------------------------------------------- C NORMALIZE AMAX1(SX,SY) = 1. C----------------------------------------------- 35 R = R0/DM S1 = SX/DM S2 = SY/DM H8 = H8/DM K8 = K8/DM H2 = H2/(DM*DM) C--------------------------------- C S1 = 1 .GE. S2 C--------------------------------- IF (S1 .GE. S2) GO TO 40 H1 = S1 S1 = S2 S2 = H1 H1 = H8 H8 = K8 K8 = H1 C----------------------------------------------- C LIMITING RESULTS FOR AMIN1(S1,S2) = 0 C----------------------------------------------- 40 SEPS1 = AMIN1(6.71*SQEPS,1.E-5) C----------------------------------------------- C R = K, S2 SMALL C----------------------------------------------- IF (K8 .NE. R) GO TO 45 YY = .166484*(R*(H8*H8 + 1.0) + 1.0/R)*S2 IF (ABS(YY) .GT. SEPS1) GO TO 85 H1 = H8/RT2 P = C*EXP(-H1*H1)*SQRT(K8*S2) RETURN C----------------------------------------------- C R .GT. K, S2 SMALL C----------------------------------------------- 45 IF (R .LT. K8) GO TO 85 IF (K8 .NE. 0.0) GO TO 75 H1 = S2*S2/(4.0*RT2*R) G2 = G2/RT2 IF (J .EQ. 0) G2 = ABS(H8 - R)/RT2 IF (ABS(G2) .LT. 4.0) GO TO 55 IF (H1*ABS(G2) .GT. SEPS1) GO TO 85 P = 0.5*AERF(H8/RT2,R/RT2) RETURN 55 IF (J .NE. 0) GO TO 60 P = 0.5*AERF(H8/RT2,R/RT2) GO TO 70 60 IF (H8 + R .LT. RT2) GO TO 65 P = 0.5*(ERFC(G2) - ERFC((H8 + R)/RT2)) GO TO 70 65 P = 0.5*(ERF((H8 + R)/RT2) - ERF(G2)) 70 IF (H1*EXP(-G2*G2) .GT. P*SEPS1) GO TO 85 RETURN C 75 Z = (R - K8)*(R + K8) G2 = SQRT(Z) H1 = ABS(H8 - G2) J = 0 IF (H1 .GT. 5.0) GO TO 80 J = 1 Z8 = AERF(H8/RT2,G2/RT2) IF (Z8 .EQ. 0.0) GO TO 85 H1 = EXP(-0.5*(H8 - G2)**2)/Z8 80 H1 = 1.0/(8.0*RT2*Z)*(K8*K8*ABS(H8 - G2) + R*R/G2)*S2*S2*H1 IF (ABS(H1) .GT. SEPS1) GO TO 85 U = 0.5 IF (J .EQ. 0) Z8 = AERF(H8/RT2,G2/RT2) S2 = RT2*S2 IF (K8 - R .GT. -13.0*S2) U = 0.25*AERF(K8/S2,R/S2) P = U*Z8 RETURN C---------------------------- C FIND THE VALUE OF A C---------------------------- 85 S0 = S1*S1 S9 = S2*S2 G3 = H8*H8 G2 = K8*K8 Z8 = S0 + S9 Z = S0*S0 + S9*S9 H3 = G3*S0 + G2*S9 T1 = 2.0*(Z + 2*H3) YY = R*R*(H2 + Z8)/T1 T1 = (H2 + Z8)*(H2 + Z8)/T1 CALL GRATIO (T1,YY,Z,Z8,0) Z2 = R/(RT2*S2) R8 = R/(RT2*S1) H2 = H8/(RT2*S1) H3 = K8/(RT2*S2) S0 = 0.0 S9 = 0.0 IF (Z .LT. 1.E-13 .AND. S2 .GT. 5.E-10) GO TO 90 IF (H2 .GT. 50.0 .OR. H3 .GT. 50.0) S0 = 1.5 90 U = AERF(H3,Z2) YY = 0.25*U*AERF(H2,R8) IF (YY .GT. 0.1) S9 = 0.5 IF (YY .GE. 5.E-15) GO TO 95 Z = YY GO TO 100 95 Z = AMIN1(YY,Z) C 100 IF (Z .GE. 0.5) GO TO 105 A = A + .5 IF (Z .GE. 5.E-4) GO TO 105 A = A + .5 + S0 IF (Z .GE. 1.E-6) GO TO 105 A = A + .5 + S9 IF (Z .GE. 5.E-9) GO TO 105 A = A + .5 IF (Z .GE. 5.E-10) GO TO 105 A = A + .25 IF (Z .GE. 5.E-11) GO TO 105 A = A + .25 IF (Z .GE. 5.E-12) GO TO 105 A = A + .25 IF (Z .GE. 5.E-13) GO TO 105 A = A + .5 + .5*S9 IF (Z .GT. 5.E-15) GO TO 105 A = A + .5 IF (Z .GT. 1.E-18) GO TO 105 A = A + .25 IF (Z .GT. 1.E-20) GO TO 105 A = A + .25 IF (Z .GT. 1.E-25) GO TO 105 A = A + 1. IF (Z .GT. 1.E-30) GO TO 105 A = A + 2. C 105 IF (S2 .GE. 5.E-2 .OR. H3 .LE. Z2) GO TO 107 T9 = R8*U*EXP(-H2*H2) IF (T9 .LT. 5.E-2 * Z) A = A + 0.5 C--------------------------------------- C START INTEGRATION PROCEDURE C--------------------------------------- 107 S0 = S1 S9 = S2 Z8 = S2 G2 = K8 G3 = H8 Z9 = S1 J8 = 0 C------------------------------------------------- C DETERMINE INTERVAL OF INTEGRATION, (A,RT2). C E3 = (RT2-A)/2, D1 = (RT2+A)/2. C------------------------------------------------- 110 Z = G2 + A*Z8 H3 = G2 - A*Z8 H5 = 0.0 T3 = -1.0 A1 = (G3 - A*Z9)/R IF (ABS(A1 - 0.5) .GE. 0.5) GO TO 115 A2 = AMAX1(((1.0 - G3/R) + A*Z9/R)*(1.0 + A1), 0.0) SA = SQRT(A2) IF (SA .LT. H3/R) GO TO 115 T3 = A1/SQRT(1.0 + SA) C---------------------------------------- C T9 = 1.0 - D1 C---------------------------------------- 115 IF (H3 .GT. 0.0) GO TO 135 C---------------------------------------- C H3 .LE. 0.0 C---------------------------------------- IF (T3 .LT. 0.0) GO TO 120 D2 = 0.5*(1.0 + T3) E4 = 0.25*SA/D2 T5 = E4 120 IF (Z .LT. R) GO TO 125 E3 = 0.5 D1 = E3 T9 = D1 GO TO 130 125 D1 = 0.5*(1.0 + SQRT(1.0 - Z/R)) E3 = 0.25*Z/(R*D1) T9 = E3 130 IF (T3 .LE. D1 - E3) GO TO 165 GO TO 160 C---------------------------------------- C H3 .GT. 0.0 C---------------------------------------- 135 H5 = 1.0 Q = H3/R IF (Q .LE. 1.0) GO TO 140 E3 = 0.5 D1 = E3 T9 = D1 GO TO 165 140 IF (T3 .LT. 0.0) GO TO 145 E4 = AMAX1((1.0 - G2/R) + A*Z8/R, 0.0) E4 = SQRT(E4) D2 = 0.5*(E4 + T3) T5 = 0.5*(Q/(1.0 + E4) + SA/(1.0 + T3)) E4 = 0.25*(SA - Q)/D2 145 E3 = AMAX1((1.0 - G2/R) + A*Z8/R, 0.0) IF (Z .LT. R) GO TO 150 E3 = 0.5*SQRT(E3) D1 = E3 T9 = 0.25*(3.0 + H3/R)/(1.0 + E3) GO TO 155 150 T9 = SQRT(E3) T2 = SQRT(1.0 - Z/R) D1 = 0.5*(T9 + T2) E3 = A*Z8/(R*2.0*D1) T9 = 0.5*((H3/R)/(1.0 + T9) + (Z/R)/(1.0 + T2)) 155 IF (T3 .LE. D1 - E3) GO TO 165 160 E3 = E4 D1 = D2 T9 = T5 165 IF (J8 .NE. 0) GO TO 170 J8 = 1 F = E3 T = D1 T1 = T9 H6 = H5 Z8 = S1 G2 = H8 G3 = K8 Z9 = S2 GO TO 110 C----------------------------------------------------------------------- C DETERMINE IN WHICH ORDER THE X AMD Y INTEGRATIONS ARE CARRIED OUT. C----------------------------------------------------------------------- 170 IF (S2 .GT. 2.E-2 .AND. H8 + K8 .LT. 2.E2) GO TO 172 IF (ABS(E3 - F) .GT. 0.4*F) GO TO 172 IF (D1 - T) 200,180,195 172 IF (E3 .LT. 2.E4*EPS) GO TO 195 IF (F .LT. 2.E4*EPS) GO TO 200 IF (AMAX1(H8/S1,K8/S2) .LT. 2.0) GO TO 175 IF (S2 .LT. 1.E-5) GO TO 175 IF (S2 .GE. 5.E-4) GO TO 180 IF (S1 .NE. S2) GO TO 195 175 IF (AMIN1(E3,F) .LT. 2.5E-2*SQEPS) GOTO 185 180 IF (E3 - F) 200,190,195 185 IF (E3 - F) 195,190,200 190 IF (S0 .GE. S9) GO TO 200 195 E3 = F D1 = T T9 = T1 S9 = S1 S0 = S2 Z8 = H8 H8 = K8 K8 = Z8 H5 = H6 200 Z2 = R/(RT2*S9) R8 = R/(RT2*S0) H2 = H8/(RT2*S0) H3 = K8/(RT2*S9) N1 = 16 IZ = 0 IZ3 = 0 IY = 0 P = 0.0 T = H2 - R8 + R8*(D1 - E3*V(16))**2 IF (T .GT. 0.0 .AND. T*T .GT. -EXPARG(1)) RETURN C Q1 = RPI*E3*R8 G3 = 0.0 NT = 2*N1 + 1 Z = (.5 + D1) +.5 DO 260 II = 1, NT I = II - (N1 + 1) IF (I .EQ. 0) GO TO 260 J = IABS(I) Q = E3*ISIGN(1,I)*V(J) T = Q + D1 H6 = Z + Q Q = T9 - Q F = H6*Q T1 = R8*F T2 = (H2 - T1)*(H2 - T1) IF (H2 - R8 .GE. 0. .OR. T .LT. EPS) T2 = * ((H2 - R8) + R8*T*T)**2 T4 = EXP(-T2) IF (H2 .NE. 0.0) GO TO 210 T4 = T4 + T4 GO TO 215 210 IF (H5 .NE. 0.0) GO TO 215 T2 = 4.0*H2*T1 IF (T2 .GT. C8) GO TO 215 T4 = T4*(1.0 + EXP(-T2)) 215 IF (IZ .NE. 0) GO TO 255 G2 = SQRT(1.0 + F) Z1 = Z2*T*G2 X1 = H3 - Z1 IF (X1 .GT. -A) GO TO 225 IZ = 1 X5 = 2.0 GO TO 255 225 IF (ABS(X1) .GT. 1.E-2*Z1) GO TO 230 IY = 1 X1 = ((K8 - R) + R*F*F/(1.0 + T*G2))/(RT2*S9) 230 IF (IZ3 .NE. 0) GO TO 250 SA = H3 + Z1 IF (SA .GT. A3) GO TO 245 IF (IY .EQ. 0) GO TO 240 IF (X1 .GT. RT2) GO TO 235 X5 = ERF(SA) - ERF(X1) GO TO 255 235 X5 = ERFC(X1) - ERFC(SA) GO TO 255 240 X5 = AERF(H3,Z1) GO TO 255 245 IZ3 = 1 250 X5 = ERFC(X1) 255 G3 = G3 + X5*T4*T*W(J) 260 CONTINUE P = Q1*G3 IF (P .GT. YY) P = YY IF (P .GT. (1.0 - AMIN1(1.E6*EPS,1.E-5))) P = 1.0 IF (P .LT. 0.0) P = 0.0 RETURN END SUBROUTINE PLCOPY (A,KA,M,B,KB,N) C ------------------------------------------------------------------ C COPYING REAL POLYNOMIALS C ------------------------------------------------------------------ REAL A(*), B(*) C LA = 1 LB = 1 JMAX = MIN0(M, N) DO 10 J = 1,JMAX B(LB) = A(LA) LA = LA + KA LB = LB + KB 10 CONTINUE IF (JMAX .EQ. N) RETURN C MP1 = M + 1 DO 20 J = MP1,N B(LB) = 0.0 LB = LB + KB 20 CONTINUE RETURN END SUBROUTINE DPCOPY (A,KA,M,B,KB,N) C ------------------------------------------------------------------ C COPYING DOUBLE PRECISION POLYNOMIALS C ------------------------------------------------------------------ DOUBLE PRECISION A(*), B(*) C LA = 1 LB = 1 JMAX = MIN0(M, N) DO 10 J = 1,JMAX B(LB) = A(LA) LA = LA + KA LB = LB + KB 10 CONTINUE IF (JMAX .EQ. N) RETURN C MP1 = M + 1 DO 20 J = MP1,N B(LB) = 0.D0 LB = LB + KB 20 CONTINUE RETURN END SUBROUTINE PADD (A,KA,L,B,KB,M,C,KC,N) C ------------------------------------------------------------------ C ADDITION OF REAL POLYNOMIALS C ------------------------------------------------------------------ REAL A(*), B(*), C(*) C LA = 1 LB = 1 LC = 1 DO 10 I = 1,N C(LC) = 0.0 IF (I .LE. L) C(LC) = A(LA) IF (I .LE. M) C(LC) = C(LC) + B(LB) LA = LA + KA LB = LB + KB LC = LC + KC 10 CONTINUE RETURN END SUBROUTINE DPADD (A,KA,L,B,KB,M,C,KC,N) C ------------------------------------------------------------------ C ADDITION OF DOUBLE PRECISION POLYNOMIALS C ------------------------------------------------------------------ DOUBLE PRECISION A(*), B(*), C(*) C LA = 1 LB = 1 LC = 1 DO 10 I = 1,N C(LC) = 0.D0 IF (I .LE. L) C(LC) = A(LA) IF (I .LE. M) C(LC) = C(LC) + B(LB) LA = LA + KA LB = LB + KB LC = LC + KC 10 CONTINUE RETURN END SUBROUTINE PSUBT (A,KA,L,B,KB,M,C,KC,N) C ------------------------------------------------------------------ C SUBTRACTION OF REAL POLYNOMIALS C ------------------------------------------------------------------ REAL A(*), B(*), C(*) C LA = 1 LB = 1 LC = 1 DO 10 I = 1,N C(LC) = 0.0 IF (I .LE. L) C(LC) = A(LA) IF (I .LE. M) C(LC) = C(LC) - B(LB) LA = LA + KA LB = LB + KB LC = LC + KC 10 CONTINUE RETURN END SUBROUTINE DPSUBT (A,KA,L,B,KB,M,C,KC,N) C ------------------------------------------------------------------ C SUBTRACTION OF DOUBLE PRECISION POLYNOMIALS C ------------------------------------------------------------------ DOUBLE PRECISION A(*), B(*), C(*) C LA = 1 LB = 1 LC = 1 DO 10 I = 1,N C(LC) = 0.D0 IF (I .LE. L) C(LC) = A(LA) IF (I .LE. M) C(LC) = C(LC) - B(LB) LA = LA + KA LB = LB + KB LC = LC + KC 10 CONTINUE RETURN END SUBROUTINE PMULT (A,KA,L,B,KB,M,C,KC,N) C ------------------------------------------------------------------ C MULTIPLICATION OF REAL POLYNOMIALS C ------------------------------------------------------------------ REAL A(*), B(*), C(*) DOUBLE PRECISION DSUM C LC = 1 JMAX = MIN0(L + M - 1, N) DO 40 J = 1,JMAX IF (J .LE. L) GO TO 10 IMIN = 1 + (J - L) LA = 1 + (L - 1)*KA LB = 1 + (IMIN - 1)*KB GO TO 20 10 IMIN = 1 LA = 1 + (J - 1)*KA LB = 1 C 20 IMAX = MIN0(J, M) DSUM = 0.D0 DO 30 I = IMIN,IMAX DSUM = DSUM + DBLE(A(LA))*DBLE(B(LB)) LA = LA - KA LB = LB + KB 30 CONTINUE C(LC) = DSUM 40 LC = LC + KC IF (JMAX .EQ. N) RETURN C JMIN = JMAX + 1 DO 60 J = JMIN,N C(LC) = 0.0 60 LC = LC + KC RETURN END SUBROUTINE DPMULT (A,KA,L,B,KB,M,C,KC,N) C ------------------------------------------------------------------ C MULTIPLICATION OF DOUBLE PRECISION POLYNOMIALS C ------------------------------------------------------------------ DOUBLE PRECISION A(*), B(*), C(*) DOUBLE PRECISION SUM C LC = 1 JMAX = MIN0(L + M - 1, N) DO 40 J = 1,JMAX IF (J .LE. L) GO TO 10 IMIN = 1 + (J - L) LA = 1 + (L - 1)*KA LB = 1 + (IMIN - 1)*KB GO TO 20 10 IMIN = 1 LA = 1 + (J - 1)*KA LB = 1 C 20 IMAX = MIN0(J, M) SUM = 0.D0 DO 30 I = IMIN,IMAX SUM = SUM + A(LA)*B(LB) LA = LA - KA LB = LB + KB 30 CONTINUE C(LC) = SUM 40 LC = LC + KC IF (JMAX .EQ. N) RETURN C JMIN = JMAX + 1 DO 60 J = JMIN,N C(LC) = 0.D0 60 LC = LC + KC RETURN END SUBROUTINE PDIV (A,KA,L,B,KB,M,C,KC,N,IERR) C ------------------------------------------------------------------ C DIVISION OF REAL POLYNOMIALS C ------------------------------------------------------------------ REAL A(*), B(*), C(*) DOUBLE PRECISION DSUM C B0 = B(1) IF (B0 .EQ. 0.0) GO TO 100 IERR = 0 C(1) = A(1)/B0 IF (N .EQ. 1) RETURN C C CASE WHEN M = 1 C IF (M .GT. 1) GO TO 20 LA = 1 LC = 1 DO 10 J = 2,N LA = LA + KA LC = LC + KC C(LC) = 0.0 IF (J .LE. L) C(LC) = A(LA)/B0 10 CONTINUE RETURN C C CASE WHEN M .GT. 1 C 20 LA = 1 LC = 1 DO 40 J = 2,N LA = LA + KA LC = LC + KC IB = 1 IC = LC DSUM = 0.D0 IF (J .LE. L) DSUM = A(LA) IMAX = MIN0(J, M) DO 30 I = 2,IMAX IB = IB + KB IC = IC - KC DSUM = DSUM - DBLE(B(IB))*DBLE(C(IC)) 30 CONTINUE C(LC) = SNGL(DSUM)/B0 40 CONTINUE RETURN C C ERROR RETURN C 100 IERR = 1 RETURN END SUBROUTINE DPDIV (A,KA,L,B,KB,M,C,KC,N,IERR) C ------------------------------------------------------------------ C DIVISION OF DOUBLE PRECISION POLYNOMIALS C ------------------------------------------------------------------ DOUBLE PRECISION A(*), B(*), C(*) DOUBLE PRECISION B0, SUM C B0 = B(1) IF (B0 .EQ. 0.D0) GO TO 100 IERR = 0 C(1) = A(1)/B0 IF (N .EQ. 1) RETURN C C CASE WHEN M = 1 C IF (M .GT. 1) GO TO 20 LA = 1 LC = 1 DO 10 J = 2,N LA = LA + KA LC = LC + KC C(LC) = 0.D0 IF (J .LE. L) C(LC) = A(LA)/B0 10 CONTINUE RETURN C C CASE WHEN M .GT. 1 C 20 LA = 1 LC = 1 DO 40 J = 2,N LA = LA + KA LC = LC + KC IB = 1 IC = LC SUM = 0.D0 IF (J .LE. L) SUM = A(LA) IMAX = MIN0(J, M) DO 30 I = 2,IMAX IB = IB + KB IC = IC - KC SUM = SUM - B(IB)*C(IC) 30 CONTINUE C(LC) = SUM/B0 40 CONTINUE RETURN C C ERROR RETURN C 100 IERR = 1 RETURN END SUBROUTINE PLPWR(R,A,KA,M,B,KB,N,IERR) C ------------------------------------------------------------------ C SET B = A**R WHERE A IS A REAL POLYNOMIAL C ------------------------------------------------------------------ REAL A(*), B(*) REAL JM1 DOUBLE PRECISION COEFF, DSUM, RP1 C A0 = A(1) IF (A0 .LE. 0.0) GO TO 100 IERR = 0 B(1) = A0**R IF (N .EQ. 1) RETURN C C CASE WHEN M = 1 OR R = 0 C IF (M .GT. 1 .AND. R .NE. 0.0) GO TO 20 LB = 1 DO 10 J = 2,N LB = LB + KB B(LB) = 0.0 10 CONTINUE RETURN C C GENERAL CASE C 20 RP1 = DBLE(R) + 1.D0 LB = 1 DO 40 J = 2,N LB = LB + KB JM1 = J - 1 IA = 1 IB = LB COEFF = -JM1 DSUM = 0.D0 IMAX = MIN0(J, M) DO 30 I = 2,IMAX IA = IA + KA IB = IB - KB COEFF = COEFF + RP1 DSUM = DSUM + COEFF*DBLE(A(IA))*DBLE(B(IB)) 30 CONTINUE B(LB) = SNGL(DSUM)/(JM1*A0) 40 CONTINUE RETURN C C ERROR RETURN C 100 IERR = 1 RETURN END SUBROUTINE DPLPWR(R,A,KA,M,B,KB,N,IERR) C ------------------------------------------------------------------ C SET B = A**R WHERE A IS A DOUBLE PRECISION POLYNOMIAL C ------------------------------------------------------------------ DOUBLE PRECISION A(*), B(*), R DOUBLE PRECISION A0, COEFF, JM1, RP1, SUM C A0 = A(1) IF (A0 .LE. 0.D0) GO TO 100 IERR = 0 B(1) = A0**R IF (N .EQ. 1) RETURN C C CASE WHEN M = 1 OR R = 0 C IF (M .GT. 1 .AND. R .NE. 0.D0) GO TO 20 LB = 1 DO 10 J = 2,N LB = LB + KB B(LB) = 0.D0 10 CONTINUE RETURN C C GENERAL CASE C 20 RP1 = R + 1.D0 LB = 1 DO 40 J = 2,N LB = LB + KB JM1 = J - 1 IA = 1 IB = LB COEFF = -JM1 SUM = 0.D0 IMAX = MIN0(J, M) DO 30 I = 2,IMAX IA = IA + KA IB = IB - KB COEFF = COEFF + RP1 SUM = SUM + COEFF*A(IA)*B(IB) 30 CONTINUE B(LB) = SUM/(JM1*A0) 40 CONTINUE RETURN C C ERROR RETURN C 100 IERR = 1 RETURN END SUBROUTINE PINV (A, D, N, Q) C----------------------------------------------------------------------- C COMPUTATION OF THE INVERSE OF THE POWER SERIES C SUM (A(I)*X**I, I = 1,2,...) C----------------------------------------------------------------------- REAL A(N), D(N), Q(*) C---------------------------- C NUM = (N*(N + 1))/2 C REAL Q(NUM) C---------------------------- C C COMPUTE THE COEFFICIENT MATRIX Q C Q(1) = 1.0 K = 2 DO 10 I = 2,N Q(K) = 0.0 10 K = K + I C JJ = 1 DO 22 J = 2,N L0 = JJ JJ = (J*(J + 1))/2 K = JJ DO 21 I = J,N SUM = 0.0 M = I - J + 2 LL = L0 DO 20 L = J,I SUM = SUM + A(M)*Q(LL) M = M - 1 LL = LL + (L - 1) 20 CONTINUE Q(K) = SUM K = K + I 21 CONTINUE 22 CONTINUE C C COMPUTE THE COEFFICIENTS OF THE INVERSE C K = 1 DO 31 J = 1,N U = 1.0/(J*A(1)**J) SUM = 0.0 DO 30 L = 1,J SUM = SUM + U*Q(K) S = L + J - 1 T = L U = -(S*U)/(T*A(1)) K = K + 1 30 CONTINUE D(J) = SUM 31 CONTINUE RETURN END SUBROUTINE DPINV (A, D, N, Q) C----------------------------------------------------------------------- C COMPUTATION OF THE INVERSE OF THE POWER SERIES C SUM (A(I)*X**I, I = 1,2,...) C----------------------------------------------------------------------- DOUBLE PRECISION A(N), D(N), Q(*) DOUBLE PRECISION S, SUM, T, U C---------------------------- C NUM = (N*(N + 1))/2 C REAL Q(NUM) C---------------------------- C C COMPUTE THE COEFFICIENT MATRIX Q C Q(1) = 1.D0 K = 2 DO 10 I = 2,N Q(K) = 0.D0 10 K = K + I C JJ = 1 DO 22 J = 2,N L0 = JJ JJ = (J*(J + 1))/2 K = JJ DO 21 I = J,N SUM = 0.D0 M = I - J + 2 LL = L0 DO 20 L = J,I SUM = SUM + A(M)*Q(LL) M = M - 1 LL = LL + (L - 1) 20 CONTINUE Q(K) = SUM K = K + I 21 CONTINUE 22 CONTINUE C C COMPUTE THE COEFFICIENTS OF THE INVERSE C K = 1 DO 31 J = 1,N U = 1.D0/(J*A(1)**J) SUM = 0.D0 DO 30 L = 1,J SUM = SUM + U*Q(K) S = L + J - 1 T = L U = -(S*U)/(T*A(1)) K = K + 1 30 CONTINUE D(J) = SUM 31 CONTINUE RETURN END SUBROUTINE MPLNMV (MO, AU, NC, AC, FV) C ****************************************************************** C FORTRAN SUBROUTINE FOR MULTIPLEX POLYNOMIAL EVALUATION C ****************************************************************** C MO = MODE OF OPERATION C AU = ARGUMENT U C NC = NUMBER OF COEFFICIENTS C AC = ARRAY OF COEFFICIENTS C FV = FUNCTION V C C MO = -1 FOR INTEGRAL C MO = 0 FOR FUNCTION C MO = +1 FOR FIRST DERIVATIVE C MO = +2 FOR SECOND DERIVATIVE C DIMENSION AC(*) 001 FV=0.0 L=NC IF(MO.LT.0)GO TO 002 IF(MO.EQ.0)GO TO 004 IF(MO.EQ.1)GO TO 006 IF(MO.GE.2)GO TO 008 002 QL=NC DO 003 K=1,NC FV=AC(L)/QL+AU*FV L=L-1 QL=QL-1.0 003 CONTINUE FV=AU*FV RETURN 004 DO 005 K=1,NC FV=AC(L)+AU*FV L=L-1 005 CONTINUE RETURN 006 IF(NC.LE.1)RETURN QL=NC DO 007 K=2,NC QL=QL-1.0 FV=QL*AC(L)+AU*FV L=L-1 007 CONTINUE RETURN 008 IF(NC.LE.2)RETURN QL=NC DO 009 K=3,NC QL=QL-1.0 FV=QL*(QL-1.0)*AC(L)+AU*FV L=L-1 009 CONTINUE RETURN END REAL FUNCTION CSEVL (X, A, N) C----------------------------------------------------------------------- C EVALUATE THE N TERM CHEBYSHEV SERIES A AT X. C ONLY HALF OF THE FIRST COEFFICIENT IS USED. C----------------------------------------------------------------------- REAL A(N) C IF (N .GT. 1) GO TO 10 CSEVL = 0.5 * A(1) RETURN C 10 X2 = X + X S0 = A(N) S1 = 0.0 DO 20 I = 2,N S2 = S1 S1 = S0 K = N - I + 1 S0 = X2*S1 - S2 + A(K) 20 CONTINUE CSEVL = 0.5 * (S0 - S2) RETURN END DOUBLE PRECISION FUNCTION DCSEVL (X, A, N) C----------------------------------------------------------------------- C EVALUATE THE N TERM CHEBYSHEV SERIES A AT X. C ONLY HALF OF THE FIRST COEFFICIENT IS USED. C----------------------------------------------------------------------- DOUBLE PRECISION A(N),X,X2,S0,S1,S2 C IF (N .GT. 1) GO TO 10 DCSEVL = 0.5D0 * A(1) RETURN C 10 X2 = X + X S0 = A(N) S1 = 0.D0 DO 20 I = 2,N S2 = S1 S1 = S0 K = N - I + 1 S0 = X2*S1 - S2 + A(K) 20 CONTINUE DCSEVL = 0.5D0 * (S0 - S2) RETURN END SUBROUTINE LGRNGN (AU, NA, AN) C ****************************************************************** C FORTRAN SUBROUTINE FOR LAGRANGIAN NORMALIZATION FACTORS C ****************************************************************** C AU = COORDINATE ARGUMENTS (N-ARRAY) C NA = NUMBER OF ARGUMENTS (N) C AN = NORMALIZATION FACTORS (N-ARRAY) C DIMENSION AU(*), AN(*) 001 DO 003 K=1,NA TM=1.0 DO 002 M=1,NA IF(M.EQ.K)GO TO 002 DM=AU(K)-AU(M) TM=DM*TM 002 CONTINUE AN(K)=TM 003 CONTINUE RETURN END SUBROUTINE LGRNGV (MO, NA, QU, AU, AN, FF, DF, SF) C ****************************************************************** C FORTRAN SUBROUTINE FOR LAGRANGIAN FUNCTION EVALUATION C ****************************************************************** C MO = MODE OF OPERATION C NA = NUMBER OF STATIONS C QU = ARGUMENT OF FUNCTIONS C AU = STATION COORDINATES (N-ARRAY) C AN = NORMALIZATION FACTORS (N-ARRAY) C FF = LAGRANGIAN FUNCTIONS (N-ARRAY) C DF = FIRST DERIVATIVES (N-ARRAY) C SF = SECOND DERIVATIVES (N-ARRAY) C C CALL LGRNGV (0, NA, QU, AU, AN, FF) FOR FUNCTIONS C CALL LGRNGV (1, NA, QU, AU, AN, FF, DF) FOR FIRST DERIVATIVES C CALL LGRNGV (2, NA, QU, AU, AN, FF, DF, SF) FOR SECOND DERIVATIVES C DIMENSION AU(*), AN(*), FF(*), DF(*), SF(*) LOGICAL LN 001 LN=.TRUE. TM=1.0 DO 003 K=1,NA IF(QU.NE.AU(K))GO TO 002 LN=.FALSE. GO TO 003 002 DM=QU-AU(K) TM=DM*TM 003 CONTINUE DO 007 K=1,NA IF(LN)GO TO 005 IF(QU.NE.AU(K))GO TO 005 FF(K)=TM GO TO 006 005 DM=QU-AU(K) FF(K)=TM/DM 006 FF(K)=FF(K)/AN(K) 007 CONTINUE IF(MO.LE.0)GO TO 050 SM=0.0 DO 013 K=1,NA DF(K)=SM IF(LN)GO TO 012 IF(QU.EQ.AU(K))GO TO 013 012 DM=QU-AU(K) SM=SM+1.0/DM 013 CONTINUE RM=SM IF(MO.EQ.1)GO TO 040 SM=0.0 DO 023 K=1,NA SF(K)=SM IF(LN)GO TO 022 IF(QU.EQ.AU(K))GO TO 023 022 DM=QU-AU(K) SM=SM+2.0*DF(K)/DM 023 CONTINUE SM=0.0 TM=0.0 L=NA IF(LN)GO TO 034 DO 033 K=1,NA SF(L)=TM+SF(L)+2.0*SM*DF(L) IF(QU.EQ.AU(L))GO TO 032 SF(L)=2.0*(SM+DF(L)) DM=QU-AU(L) TM=TM+2.0*SM/DM SM=SM+1.0/DM 032 L=L-1 033 CONTINUE GO TO 036 034 DO 035 K=1,NA SF(L)=TM+SF(L)+2.0*SM*DF(L) DM=QU-AU(L) TM=TM+2.0*SM/DM SM=SM+1.0/DM L=L-1 035 CONTINUE 036 DO 037 K=1,NA SF(K)=FF(K)*SF(K) 037 CONTINUE 040 IF (LN) GO TO 043 DO 042 K=1,NA IF (QU.NE.AU(K)) GO TO 041 DF(K)=RM FF(K)=1.0 GO TO 042 041 DF(K)=FF(K) FF(K)=0.0 042 CONTINUE RETURN 043 SM=0.0 L=NA DO 044 K=1,NA DF(L)=FF(L)*(SM+DF(L)) SM=SM+1.0/(QU-AU(L)) L=L-1 044 CONTINUE RETURN 050 IF(LN)GO TO 053 DO 052 K=1,NA FF(K)=0.0 IF(QU.NE.AU(K))GO TO 052 FF(K)=1.0 052 CONTINUE 053 RETURN END SUBROUTINE LGRNGX (AU, NA, AC) C ****************************************************************** C FORTRAN SUBROUTINE FOR LAGRANGIAN POLYNOMIAL EXPANSION C ****************************************************************** C AU = COORDINATE ARGUMENTS (N-ARRAY) C NA = NUMBER OF ARGUMENTS (N) C AC = POLYNOMIAL COEFFICIENTS (NX(N+1) ARRAY) C DIMENSION AU(*), AC(*) 001 DO 003 I=1,NA K=(I-1)*NA L=K+I AC(L)=1.0 SM=0.0 DO 002 J=1,I K=K+1 L=K+NA AC(L)=SM-AU(I)*AC(K) SM=AC(K) 002 CONTINUE 003 CONTINUE DO 005 I=1,NA K=NA+NA*NA L=I*NA AC(L)=1.0 DO 004 J=2,NA SM=AU(I)*AC(L) L=L-1 AC(L)=SM+AC(K) K=K-1 004 CONTINUE 005 CONTINUE DO 008 I=1,NA TM=1.0 DO 006 J=1,NA IF(J.EQ.I)GO TO 006 TD=AU(I)-AU(J) TM=TM*TD 006 CONTINUE K=(I-1)*NA DO 007 J=1,NA K=K+1 AC(K)=AC(K)/TM 007 CONTINUE 008 CONTINUE RETURN END SUBROUTINE ORTHOS (AU, MA, AA, NA, AR) C ****************************************************************** C FORTRAN SUBROUTINE FOR ORTHONORMAL POLYNOMIAL SYNTHESIS C ****************************************************************** C AU = COORDINATE ARGUMENTS (N ARRAY) C MA = NUMBER OF COLUMNS (M) C AA = MATRIX OF POLYNOMIALS (NXM ARRAY) C NA = NUMBER OF ROWS (N) C AR = RECURRENCE COEFFICIENTS (2*M-2 ARRAY) C DIMENSION AU(*), AA(*), AR(*) 001 SN=NA RN=SQRT(SN) DO 002 I=1,NA AA(I)=1.0/RN 002 CONTINUE IF(MA.EQ.1)RETURN 003 SM=0.0 DO 004 I=1,NA SM=SM+AU(I) 004 CONTINUE AR(2)=SM/SN SM=0.0 L=NA DO 005 I=1,NA L=L+1 AA(L)=AU(I)-AR(2) SM=SM+AA(L)*AA(L) 005 CONTINUE RM=SQRT(SM) L=NA DO 006 I=1,NA L=L+1 AA(L)=AA(L)/RM 006 CONTINUE SM=0.0 L=NA DO 007 I=1,NA L=L+1 SM=SM+AU(I)*AA(L) 007 CONTINUE AR(1)=SM/RN IF(MA.EQ.2)RETURN 008 DO 013 M=3,MA SM=0.0 K=(M-2)*NA DO 009 I=1,NA K=K+1 SM=SM+AU(I)*AA(K)*AA(K) 009 CONTINUE AR(2*M-2)=SM SM=0.0 J=(M-3)*NA DO 010 I=1,NA J=J+1 K=J+NA L=K+NA AA(L)=AU(I)*AA(K)-AR(2*M-2)*AA(K)-AR(2*M-5)*AA(J) SM=SM+AA(L)*AA(L) 010 CONTINUE RM=SQRT(SM) L=(M-1)*NA DO 011 I=1,NA L=L+1 AA(L)=AA(L)/RM 011 CONTINUE SM=0.0 K=(M-2)*NA DO 012 I=1,NA K=K+1 L=K+NA SM=SM+AU(I)*AA(K)*AA(L) 012 CONTINUE AR(2*M-3)=SM 013 CONTINUE RETURN END SUBROUTINE ORTHOV (MO, NA, AU, AR, NF, FF, DF, SF) C ****************************************************************** C FORTRAN SUBROUTINE FOR ORTHONORMAL POLYNOMIAL EVALUATION C ****************************************************************** C MO = MODE OF OPERATION C NA = NUMBER OF COORDINATES C AU = ARGUMENT OF FUNCTIONS C AR = RECURRENCE COEFFICIENTS (2*M-2 ARRAY) C NF = NUMBER OF FUNCTIONS (M) C FF = ORTHONORMAL FUNCTIONS (M-ARRAY) C DF = FIRST DERIVATIVES (M-ARRAY) C SF = SECOND DERIVATIVES (M-ARRAY) C C CALL ORTHOV (0, NA, AU, AR, NF, FF) FOR FUNCTIONS C CALL ORTHOV (1, NA, AU, AR, NF, FF, DF) FOR FIRST DERIVATIVES C CALL ORTHOV (2, NA, AU, AR, NF, FF, DF, SF) FOR SECOND DERIVATIVES C DIMENSION AR(*), FF(*), DF(*), SF(*) 001 SN=NA RN=SQRT(SN) FF(1)=1.0/RN IF(NF.LE.1)GO TO 003 FF(2)=(AU-AR(2))*FF(1)/AR(1) IF(NF.EQ.2)GO TO 003 L=2 DO 002 K=3,NF L=L+2 FF(K)=((AU-AR(L))*FF(K-1)-AR(L-3)*FF(K-2))/AR(L-1) 002 CONTINUE 003 IF(MO.LE.0)RETURN DF(1)=0.0 IF(NF.LE.1)GO TO 005 DF(2)=FF(1)/AR(1) IF(NF.EQ.2)GO TO 005 L=2 DO 004 K=3,NF L=L+2 DF(K)=(FF(K-1)+(AU-AR(L))*DF(K-1)-AR(L-3)*DF(K-2))/AR(L-1) 004 CONTINUE 005 IF(MO.EQ.1)RETURN SF(1)=0.0 IF(NF.LE.1)GO TO 007 SF(2)=0.0 IF(NF.EQ.2)GO TO 007 L=2 DO 006 K=3,NF L=L+2 SF(K)=(2.0*DF(K-1)+(AU-AR(L))*SF(K-1)-AR(L-3)*SF(K-2))/AR(L-1) 006 CONTINUE 007 RETURN END SUBROUTINE ORTHOX (NA, AR, NC, AC) C ****************************************************************** C FORTRAN SUBROUTINE FOR ORTHONORMAL POLYNOMIAL EXPANSION C ****************************************************************** C NA = NUMBER OF ARGUMENTS (N) C AR = RECURRENCE COEFFICIENTS (2*M-2 ARRAY) C NC = NUMBER OF COEFFICIENTS (M) C AC = POLYNOMIAL COEFFICIENTS (M*M ARRAY) C DIMENSION AR(*), AC(*) 001 DO 002 N=1,NC AC(N)=0.0 002 CONTINUE SN=NA RN=SQRT(SN) AC(1)=1.0/RN IF(NC.EQ.1)RETURN 003 TM=0.0 L=NC DO 004 N=1,NC L=L+1 AC(L)=(TM-AR(2)*AC(N))/AR(1) TM=AC(N) 004 CONTINUE IF(NC.EQ.2)RETURN 005 DO 007 M=3,NC TM=0.0 J=(M-3)*NC DO 006 N=1,NC J=J+1 K=J+NC L=K+NC AC(L)=(TM-AR(2*M-2)*AC(K)-AR(2*M-5)*AC(J))/AR(2*M-3) TM=AC(K) 006 CONTINUE 007 CONTINUE RETURN END REAL FUNCTION ZEROIN (F, AX, BX, AERR, RERR) C----------------------------------------------------------------------- C C FINDING A ZERO OF THE FUNCTION F(X) IN THE INTERVAL (AX,BX) C C ------------------------ C C INPUT... C C F FUNCTION SUBPROGRAM WHICH EVALUATES F(X) FOR ANY X IN THE C CLOSED INTERVAL (AX,BX). IT IS ASSUMED THAT F IS CONTINUOUS, C AND THAT F(AX) AND F(BX) HAVE DIFFERENT SIGNS. C AX LEFT ENDPOINT OF THE INTERVAL C BX RIGHT ENDPOINT OF THE INTERVAL C AERR THE ABSOLUTE ERROR TOLERANCE TO BE SATISFIED C RERR THE RELATIVE ERROR TOLERANCE TO BE SATISFIED C C OUTPUT... C C ABCISSA APPROXIMATING A ZERO OF F IN THE INTERVAL (AX,BX) C C----------------------------------------------------------------------- C ZEROIN IS A SLIGHTLY MODIFIED TRANSLATION OF THE ALGOL PROCEDURE C ZERO GIVEN BY RICHARD BRENT IN ALGORITHMS FOR MINIMIZATION WITHOUT C DERIVATIVES, PRENTICE-HALL, INC. (1973). C----------------------------------------------------------------------- REAL F, AX, BX, AERR, RERR EXTERNAL F REAL A,B,C,D,E,EPS,FA,FB,FC,TOL,XM,P,Q,R,S,ATOL,RTOL REAL SPMPAR C C COMPUTE EPS, THE RELATIVE MACHINE PRECISION C EPS = SPMPAR(1) C C INITIALIZATION C A = AX B = BX FA = F(A) FB = F(B) ATOL = 0.5*AERR RTOL = AMAX1(0.5*RERR,2.0*EPS) C C BEGIN STEP C 10 C = A FC = FA D = B - A E = D 20 IF (ABS(FC) .GE. ABS(FB)) GO TO 40 A = B B = C C = A FA = FB FB = FC FC = FA C C CONVERGENCE TEST C 40 TOL = RTOL*AMAX1(ABS(B),ABS(C)) + ATOL XM = 0.5*(C - B) IF (ABS(XM) .LE. TOL) GO TO 90 IF (FB .EQ. 0.0) GO TO 90 C C IS BISECTION NECESSARY C IF (ABS(E) .LT. TOL) GO TO 70 IF (ABS(FA) .LE. ABS(FB)) GO TO 70 C C IS QUADRATIC INTERPOLATION POSSIBLE C IF (A .NE. C) GO TO 50 C C LINEAR INTERPOLATION C S = FB/FC P = (C - B)*S Q = 1.0 - S GO TO 60 C C INVERSE QUADRATIC INTERPOLATION C 50 Q = FA/FC R = FB/FC S = FB/FA P = S*((C - B)*Q*(Q - R) - (B - A)*(R - 1.0)) Q = (Q - 1.0)*(R - 1.0)*(S - 1.0) C C ADJUST SIGNS C 60 IF (P .GT. 0.0) Q = -Q P = ABS(P) C C IS INTERPOLATION ACCEPTABLE C IF (2.0*P .GE. (3.0*XM*Q - ABS(TOL*Q))) GO TO 70 IF (P .GE. ABS(0.5*E*Q)) GO TO 70 E = D D = P/Q GO TO 80 C C BISECTION C 70 D = XM E = D C C COMPLETE STEP C 80 A = B FA = FB IF (ABS(D) .GT. TOL) B = B + D IF (ABS(D) .LE. TOL) B = B + SIGN(TOL,XM) FB = F(B) IF ((FB*(FC/ABS(FC))) .GT. 0.0) GO TO 10 GO TO 20 C C DONE C 90 ZEROIN = B RETURN END DOUBLE PRECISION FUNCTION DZERO (F, AX, BX, AERR, RERR) C----------------------------------------------------------------------- C C FINDING A ZERO OF THE FUNCTION F(X) IN THE INTERVAL (AX,BX) C C ------------------------ C C INPUT... C C F FUNCTION SUBPROGRAM WHICH EVALUATES F(X) FOR ANY X IN THE C CLOSED INTERVAL (AX,BX). IT IS ASSUMED THAT F IS CONTINUOUS, C AND THAT F(AX) AND F(BX) HAVE DIFFERENT SIGNS. C AX LEFT ENDPOINT OF THE INTERVAL C BX RIGHT ENDPOINT OF THE INTERVAL C AERR THE ABSOLUTE ERROR TOLERANCE TO BE SATISFIED C RERR THE RELATIVE ERROR TOLERANCE TO BE SATISFIED C C OUTPUT... C C ABCISSA APPROXIMATING A ZERO OF F IN THE INTERVAL (AX,BX) C C----------------------------------------------------------------------- C DZERO IS A SLIGHTLY MODIFIED TRANSLATION OF THE ALGOL PROCEDURE C ZERO GIVEN BY RICHARD BRENT IN ALGORITHMS FOR MINIMIZATION WITHOUT C DERIVATIVES, PRENTICE-HALL, INC. (1973). C----------------------------------------------------------------------- DOUBLE PRECISION F, AX, BX, AERR, RERR EXTERNAL F DOUBLE PRECISION A,B,C,D,E,EPS,FA,FB,FC,TOL,XM,P,Q,R,S,ATOL,RTOL DOUBLE PRECISION DPMPAR C C COMPUTE EPS, THE RELATIVE MACHINE PRECISION C EPS = DPMPAR(1) C C INITIALIZATION C A = AX B = BX FA = F(A) FB = F(B) ATOL = 0.5D0*AERR RTOL = DMAX1(0.5D0*RERR,2.D0*EPS) C C BEGIN STEP C 10 C = A FC = FA D = B - A E = D 20 IF (DABS(FC) .GE. DABS(FB)) GO TO 40 A = B B = C C = A FA = FB FB = FC FC = FA C C CONVERGENCE TEST C 40 TOL = RTOL*DMAX1(DABS(B),DABS(C)) + ATOL XM = 0.5D0*(C - B) IF (DABS(XM) .LE. TOL) GO TO 90 IF (FB .EQ. 0.D0) GO TO 90 C C IS BISECTION NECESSARY C IF (DABS(E) .LT. TOL) GO TO 70 IF (DABS(FA) .LE. DABS(FB)) GO TO 70 C C IS QUADRATIC INTERPOLATION POSSIBLE C IF (A .NE. C) GO TO 50 C C LINEAR INTERPOLATION C S = FB/FC P = (C - B)*S Q = 1.D0 - S GO TO 60 C C INVERSE QUADRATIC INTERPOLATION C 50 Q = FA/FC R = FB/FC S = FB/FA P = S*((C - B)*Q*(Q - R) - (B - A)*(R - 1.D0)) Q = (Q - 1.D0)*(R - 1.D0)*(S - 1.D0) C C ADJUST SIGNS C 60 IF (P .GT. 0.D0) Q = -Q P = DABS(P) C C IS INTERPOLATION ACCEPTABLE C IF (2.D0*P .GE. (3.D0*XM*Q - DABS(TOL*Q))) GO TO 70 IF (P .GE. DABS(0.5D0*E*Q)) GO TO 70 E = D D = P/Q GO TO 80 C C BISECTION C 70 D = XM E = D C C COMPLETE STEP C 80 A = B FA = FB IF (DABS(D) .GT. TOL) B = B + D IF (DABS(D) .LE. TOL) B = B + DSIGN(TOL,XM) FB = F(B) IF ((FB*(FC/DABS(FC))) .GT. 0.D0) GO TO 10 GO TO 20 C C DONE C 90 DZERO = B RETURN END SUBROUTINE HBRD(FCN,N,X,FVEC,EPSFCN,TOL,INFO,WA,LWA) INTEGER N,INFO,LWA REAL EPSFCN,TOL REAL X(N),FVEC(N),WA(LWA) EXTERNAL FCN C ********** C C SUBROUTINE HBRD C C THE PURPOSE OF HBRD IS TO FIND A ZERO OF A SYSTEM OF C N NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION C OF THE POWELL HYBRID METHOD. THIS IS DONE BY USING THE C MORE GENERAL NONLINEAR EQUATION SOLVER HYBRD. THE USER C MUST PROVIDE A SUBROUTINE WHICH CALCULATES THE FUNCTIONS. C THE JACOBIAN IS THEN CALCULATED BY A FORWARD-DIFFERENCE C APPROXIMATION. C C THE SUBROUTINE STATEMENT IS C C SUBROUTINE HBRD(FCN,N,X,FVEC,EPSFCN,TOL,INFO,WA,LWA) C C WHERE C C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH C CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED C IN AN EXTERNAL STATEMENT IN THE USER CALLING C PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. C C SUBROUTINE FCN(N,X,FVEC,IFLAG) C INTEGER N,IFLAG C REAL X(N),FVEC(N) C ---------- C CALCULATE THE FUNCTIONS AT X AND C RETURN THIS VECTOR IN FVEC. C --------- C RETURN C END C C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS C THE USER WANTS TO TERMINATE THE EXECUTION OF HBRD. C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. C C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER C OF FUNCTIONS AND VARIABLES. C C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. C C FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS C THE FUNCTIONS EVALUATED AT THE OUTPUT X. C C EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE C STEP LENGTH FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS C APPROXIMATION ASSUMES THAT THE RELATIVE ERRORS IN THE C FUNCTIONS ARE OF THE ORDER OF EPSFCN. IF EPSFCN IS LESS C THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE RELATIVE C ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE C PRECISION. C C TOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS C WHEN THE ALGORITHM ESTIMATES THAT THE RELATIVE ERROR C BETWEEN X AND THE SOLUTION IS AT MOST TOL. C C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, C INFO IS SET AS FOLLOWS. C C INFO = 0 IMPROPER INPUT PARAMETERS. C C INFO = 1 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR C BETWEEN X AND THE SOLUTION IS AT MOST TOL. C C INFO = 2 NUMBER OF CALLS TO FCN HAS REACHED OR EXCEEDED C 200*(N+1). C C INFO = 3 TOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN C THE APPROXIMATE SOLUTION X IS POSSIBLE. C C INFO = 4 ITERATION IS NOT MAKING GOOD PROGRESS. C C WA IS A WORK ARRAY OF LENGTH LWA. C C LWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN C (N*(3*N+13))/2. C C SUBPROGRAMS CALLED C C USER-SUPPLIED ...... FCN C C MINPACK-SUPPLIED ... HYBRD C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE C C ********** INTEGER INDEX,J,LR,MAXFEV,ML,MODE,MU,NFEV,NPRINT REAL FACTOR,ONE,XTOL,ZERO DATA FACTOR,ONE,ZERO /1.0E2,1.0E0,0.0E0/ INFO = 0 C C CHECK THE INPUT PARAMETERS FOR ERRORS. C IF (N .LE. 0 .OR. EPSFCN .LT. ZERO .OR. TOL .LT. ZERO .OR. * LWA .LT. (N*(3*N + 13))/2) GO TO 20 C C CALL HYBRD. C MAXFEV = 200*(N + 1) XTOL = TOL ML = N - 1 MU = N - 1 MODE = 2 DO 10 J = 1, N WA(J) = ONE 10 CONTINUE NPRINT = 0 LR = (N*(N + 1))/2 INDEX = 6*N + LR CALL HYBRD(FCN,N,X,FVEC,XTOL,MAXFEV,ML,MU,EPSFCN,WA(1),MODE, * FACTOR,NPRINT,INFO,NFEV,WA(INDEX+1),N,WA(6*N+1),LR, * WA(N+1),WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1)) IF (INFO .EQ. 5) INFO = 4 20 CONTINUE RETURN C C LAST CARD OF SUBROUTINE HBRD. C END SUBROUTINE HYBRD(FCN,N,X,FVEC,XTOL,MAXFEV,ML,MU,EPSFCN,DIAG, * MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,LDFJAC,R,LR, * QTF,WA1,WA2,WA3,WA4) INTEGER N,MAXFEV,ML,MU,MODE,NPRINT,INFO,NFEV,LDFJAC,LR REAL XTOL,EPSFCN,FACTOR REAL X(N),FVEC(N),DIAG(N),FJAC(LDFJAC,N),R(LR),QTF(N),WA1(N), * WA2(N),WA3(N),WA4(N) EXTERNAL FCN C ********** C C SUBROUTINE HYBRD C C THE PURPOSE OF HYBRD IS TO FIND A ZERO OF A SYSTEM OF C N NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION C OF THE POWELL HYBRID METHOD. THE USER MUST PROVIDE A C SUBROUTINE WHICH CALCULATES THE FUNCTIONS. THE JACOBIAN IS C THEN CALCULATED BY A FORWARD-DIFFERENCE APPROXIMATION. C C THE SUBROUTINE STATEMENT IS C C SUBROUTINE HYBRD(FCN,N,X,FVEC,XTOL,MAXFEV,ML,MU,EPSFCN, C DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,FJAC, C LDFJAC,R,LR,QTF,WA1,WA2,WA3,WA4) C C WHERE C C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH C CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED C IN AN EXTERNAL STATEMENT IN THE USER CALLING C PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. C C SUBROUTINE FCN(N,X,FVEC,IFLAG) C INTEGER N,IFLAG C REAL X(N),FVEC(N) C ---------- C CALCULATE THE FUNCTIONS AT X AND C RETURN THIS VECTOR IN FVEC. C --------- C RETURN C END C C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS C THE USER WANTS TO TERMINATE EXECUTION OF HYBRD. C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. C C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER C OF FUNCTIONS AND VARIABLES. C C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. C C FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS C THE FUNCTIONS EVALUATED AT THE OUTPUT X. C C XTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION C OCCURS WHEN THE RELATIVE ERROR BETWEEN TWO CONSECUTIVE C ITERATES IS AT MOST XTOL. C C MAXFEV IS A POSITIVE INTEGER INPUT VARIABLE. TERMINATION C OCCURS WHEN THE NUMBER OF CALLS TO FCN IS AT LEAST MAXFEV C BY THE END OF AN ITERATION. C C ML IS A NONNEGATIVE INTEGER INPUT VARIABLE WHICH SPECIFIES C THE NUMBER OF SUBDIAGONALS WITHIN THE BAND OF THE C JACOBIAN MATRIX. IF THE JACOBIAN IS NOT BANDED, SET C ML TO AT LEAST N - 1. C C MU IS A NONNEGATIVE INTEGER INPUT VARIABLE WHICH SPECIFIES C THE NUMBER OF SUPERDIAGONALS WITHIN THE BAND OF THE C JACOBIAN MATRIX. IF THE JACOBIAN IS NOT BANDED, SET C MU TO AT LEAST N - 1. C C EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE C STEP LENGTH FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS C APPROXIMATION ASSUMES THAT THE RELATIVE ERRORS IN THE C FUNCTIONS ARE OF THE ORDER OF EPSFCN. IF EPSFCN IS LESS C THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE RELATIVE C ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE C PRECISION. C C DIAG IS AN ARRAY OF LENGTH N. IF MODE = 1 (SEE C BELOW), DIAG IS INTERNALLY SET. IF MODE = 2, DIAG C MUST CONTAIN POSITIVE ENTRIES THAT SERVE AS C MULTIPLICATIVE SCALE FACTORS FOR THE VARIABLES. C C MODE IS AN INTEGER INPUT VARIABLE. IF MODE = 1, THE C VARIABLES WILL BE SCALED INTERNALLY. IF MODE = 2, C THE SCALING IS SPECIFIED BY THE INPUT DIAG. OTHER C VALUES OF MODE ARE EQUIVALENT TO MODE = 1. C C FACTOR IS A POSITIVE INPUT VARIABLE USED IN DETERMINING THE C INITIAL STEP BOUND. THIS BOUND IS SET TO THE PRODUCT OF C FACTOR AND THE EUCLIDEAN NORM OF DIAG*X IF NONZERO, OR ELSE C TO FACTOR ITSELF. IN MOST CASES FACTOR SHOULD LIE IN THE C INTERVAL (.1,100.). 100. IS A GENERALLY RECOMMENDED VALUE. C C NPRINT IS AN INTEGER INPUT VARIABLE THAT ENABLES CONTROLLED C PRINTING OF ITERATES IF IT IS POSITIVE. IN THIS CASE, C FCN IS CALLED WITH IFLAG = 0 AT THE BEGINNING OF THE FIRST C ITERATION AND EVERY NPRINT ITERATIONS THEREAFTER AND C IMMEDIATELY PRIOR TO RETURN, WITH X AND FVEC AVAILABLE C FOR PRINTING. IF NPRINT IS NOT POSITIVE, NO SPECIAL CALLS C OF FCN WITH IFLAG = 0 ARE MADE. C C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, C INFO IS SET AS FOLLOWS. C C INFO = 0 IMPROPER INPUT PARAMETERS. C C INFO = 1 RELATIVE ERROR BETWEEN TWO CONSECUTIVE ITERATES C IS AT MOST XTOL. C C INFO = 2 NUMBER OF CALLS TO FCN HAS REACHED OR EXCEEDED C MAXFEV. C C INFO = 3 XTOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN C THE APPROXIMATE SOLUTION X IS POSSIBLE. C C INFO = 4 ITERATION IS NOT MAKING GOOD PROGRESS, AS C MEASURED BY THE IMPROVEMENT FROM THE LAST C FIVE JACOBIAN EVALUATIONS. C C INFO = 5 ITERATION IS NOT MAKING GOOD PROGRESS, AS C MEASURED BY THE IMPROVEMENT FROM THE LAST C TEN ITERATIONS. C C NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF C CALLS TO FCN. C C FJAC IS AN OUTPUT N BY N ARRAY WHICH CONTAINS THE C ORTHOGONAL MATRIX Q PRODUCED BY THE QR FACTORIZATION C OF THE FINAL APPROXIMATE JACOBIAN. C C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. C C R IS AN OUTPUT ARRAY OF LENGTH LR WHICH CONTAINS THE C UPPER TRIANGULAR MATRIX PRODUCED BY THE QR FACTORIZATION C OF THE FINAL APPROXIMATE JACOBIAN, STORED ROWWISE. C C LR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN C (N*(N+1))/2. C C QTF IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS C THE VECTOR (Q TRANSPOSE)*FVEC. C C WA1, WA2, WA3, AND WA4 ARE WORK ARRAYS OF LENGTH N. C C SUBPROGRAMS CALLED C C USER-SUPPLIED ...... FCN C C MINPACK-SUPPLIED ... DOGLEG,SPMPAR,ENORM,FDJAC1, C QFORM,QRFAC,R1MPYQ,R1UPDT C C FORTRAN-SUPPLIED ... ABS,AMAX1,AMIN1,MIN0,MOD C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE C C ********** INTEGER I,IFLAG,ITER,J,JM1,L,MSUM,NCFAIL,NCSUC,NSLOW1,NSLOW2 INTEGER IWA(1) LOGICAL JEVAL,SING REAL ACTRED,DELTA,EPSMCH,FNORM,FNORM1,ONE,PNORM,PRERED,P1,P5, * P001,P0001,RATIO,SUM,TEMP,XNORM,ZERO REAL SPMPAR,ENORM DATA ONE,P1,P5,P001,P0001,ZERO * /1.0E0,1.0E-1,5.0E-1,1.0E-3,1.0E-4,0.0E0/ C C EPSMCH IS THE MACHINE PRECISION. C EPSMCH = SPMPAR(1) C INFO = 0 IFLAG = 0 NFEV = 0 C C CHECK THE INPUT PARAMETERS FOR ERRORS. C IF (N .LE. 0 .OR. XTOL .LT. ZERO .OR. MAXFEV .LE. 0 * .OR. ML .LT. 0 .OR. MU .LT. 0 .OR. FACTOR .LE. ZERO * .OR. LDFJAC .LT. N .OR. LR .LT. (N*(N + 1))/2) GO TO 300 IF (MODE .NE. 2) GO TO 20 DO 10 J = 1, N IF (DIAG(J) .LE. ZERO) GO TO 300 10 CONTINUE 20 CONTINUE C C EVALUATE THE FUNCTION AT THE STARTING POINT C AND CALCULATE ITS NORM. C IFLAG = 1 CALL FCN(N,X,FVEC,IFLAG) NFEV = 1 IF (IFLAG .LT. 0) GO TO 300 FNORM = ENORM(N,FVEC) C C DETERMINE THE NUMBER OF CALLS TO FCN NEEDED TO COMPUTE C THE JACOBIAN MATRIX. C MSUM = MIN0(ML+MU+1,N) C C INITIALIZE ITERATION COUNTER AND MONITORS. C ITER = 1 NCSUC = 0 NCFAIL = 0 NSLOW1 = 0 NSLOW2 = 0 C C BEGINNING OF THE OUTER LOOP. C 30 CONTINUE JEVAL = .TRUE. C C CALCULATE THE JACOBIAN MATRIX. C IFLAG = 2 CALL FDJAC1(FCN,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,EPSFCN,WA1, * WA2) NFEV = NFEV + MSUM IF (IFLAG .LT. 0) GO TO 300 C C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN. C CALL QRFAC(N,N,FJAC,LDFJAC,.FALSE.,IWA,1,WA1,WA2,WA3) C C ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING C TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN. C IF (ITER .NE. 1) GO TO 70 IF (MODE .EQ. 2) GO TO 50 DO 40 J = 1, N DIAG(J) = WA2(J) IF (WA2(J) .EQ. ZERO) DIAG(J) = ONE 40 CONTINUE 50 CONTINUE C C ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X C AND INITIALIZE THE STEP BOUND DELTA. C DO 60 J = 1, N WA3(J) = DIAG(J)*X(J) 60 CONTINUE XNORM = ENORM(N,WA3) DELTA = FACTOR*XNORM IF (DELTA .EQ. ZERO) DELTA = FACTOR 70 CONTINUE C C FORM (Q TRANSPOSE)*FVEC AND STORE IN QTF. C DO 80 I = 1, N QTF(I) = FVEC(I) 80 CONTINUE DO 120 J = 1, N IF (FJAC(J,J) .EQ. ZERO) GO TO 110 SUM = ZERO DO 90 I = J, N SUM = SUM + FJAC(I,J)*QTF(I) 90 CONTINUE TEMP = -SUM/FJAC(J,J) DO 100 I = J, N QTF(I) = QTF(I) + FJAC(I,J)*TEMP 100 CONTINUE 110 CONTINUE 120 CONTINUE C C COPY THE TRIANGULAR FACTOR OF THE QR FACTORIZATION INTO R. C SING = .FALSE. DO 150 J = 1, N L = J JM1 = J - 1 IF (JM1 .LT. 1) GO TO 140 DO 130 I = 1, JM1 R(L) = FJAC(I,J) L = L + N - I 130 CONTINUE 140 CONTINUE R(L) = WA1(J) IF (WA1(J) .EQ. ZERO) SING = .TRUE. 150 CONTINUE C C ACCUMULATE THE ORTHOGONAL FACTOR IN FJAC. C CALL QFORM(N,N,FJAC,LDFJAC,WA1) C C RESCALE IF NECESSARY. C IF (MODE .EQ. 2) GO TO 170 DO 160 J = 1, N DIAG(J) = AMAX1(DIAG(J),WA2(J)) 160 CONTINUE 170 CONTINUE C C BEGINNING OF THE INNER LOOP. C 180 CONTINUE C C IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES. C IF (NPRINT .LE. 0) GO TO 190 IFLAG = 0 IF (MOD(ITER-1,NPRINT) .EQ. 0) CALL FCN(N,X,FVEC,IFLAG) IF (IFLAG .LT. 0) GO TO 300 190 CONTINUE C C DETERMINE THE DIRECTION P. C CALL DOGLEG(N,R,LR,DIAG,QTF,DELTA,WA1,WA2,WA3) C C STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P. C DO 200 J = 1, N WA1(J) = -WA1(J) WA2(J) = X(J) + WA1(J) WA3(J) = DIAG(J)*WA1(J) 200 CONTINUE PNORM = ENORM(N,WA3) C C ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND. C IF (ITER .EQ. 1) DELTA = AMIN1(DELTA,PNORM) C C EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM. C IFLAG = 1 CALL FCN(N,WA2,WA4,IFLAG) NFEV = NFEV + 1 IF (IFLAG .LT. 0) GO TO 300 FNORM1 = ENORM(N,WA4) C C COMPUTE THE SCALED ACTUAL REDUCTION. C ACTRED = -ONE IF (FNORM1 .LT. FNORM) ACTRED = ONE - (FNORM1/FNORM)**2 C C COMPUTE THE SCALED PREDICTED REDUCTION. C L = 1 DO 220 I = 1, N SUM = ZERO DO 210 J = I, N SUM = SUM + R(L)*WA1(J) L = L + 1 210 CONTINUE WA3(I) = QTF(I) + SUM 220 CONTINUE TEMP = ENORM(N,WA3) PRERED = ZERO IF (TEMP .LT. FNORM) PRERED = ONE - (TEMP/FNORM)**2 C C COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED C REDUCTION. C RATIO = ZERO IF (PRERED .GT. ZERO) RATIO = ACTRED/PRERED C C UPDATE THE STEP BOUND. C IF (RATIO .GE. P1) GO TO 230 NCSUC = 0 NCFAIL = NCFAIL + 1 DELTA = P5*DELTA GO TO 240 230 CONTINUE NCFAIL = 0 NCSUC = NCSUC + 1 IF (RATIO .GE. P5 .OR. NCSUC .GT. 1) * DELTA = AMAX1(DELTA,PNORM/P5) IF (ABS(RATIO-ONE) .LE. P1) DELTA = PNORM/P5 240 CONTINUE C C TEST FOR SUCCESSFUL ITERATION. C IF (RATIO .LT. P0001) GO TO 260 C C SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS. C DO 250 J = 1, N X(J) = WA2(J) WA2(J) = DIAG(J)*X(J) FVEC(J) = WA4(J) 250 CONTINUE XNORM = ENORM(N,WA2) FNORM = FNORM1 ITER = ITER + 1 260 CONTINUE C C DETERMINE THE PROGRESS OF THE ITERATION. C NSLOW1 = NSLOW1 + 1 IF (ACTRED .GE. P001) NSLOW1 = 0 IF (JEVAL) NSLOW2 = NSLOW2 + 1 IF (ACTRED .GE. P1) NSLOW2 = 0 C C TEST FOR CONVERGENCE. C IF (DELTA .LE. XTOL*XNORM .OR. FNORM .EQ. ZERO) INFO = 1 IF (INFO .NE. 0) GO TO 300 C C TESTS FOR TERMINATION AND STRINGENT TOLERANCES. C IF (NFEV .GE. MAXFEV) INFO = 2 IF (P1*AMAX1(P1*DELTA,PNORM) .LE. EPSMCH*XNORM) INFO = 3 IF (NSLOW2 .EQ. 5) INFO = 4 IF (NSLOW1 .EQ. 10) INFO = 5 IF (INFO .NE. 0) GO TO 300 C C CRITERION FOR RECALCULATING JACOBIAN APPROXIMATION C BY FORWARD DIFFERENCES. C IF (NCFAIL .EQ. 2) GO TO 290 C C CALCULATE THE RANK ONE MODIFICATION TO THE JACOBIAN C AND UPDATE QTF IF NECESSARY. C DO 280 J = 1, N SUM = ZERO DO 270 I = 1, N SUM = SUM + FJAC(I,J)*WA4(I) 270 CONTINUE WA2(J) = (SUM - WA3(J))/PNORM WA1(J) = DIAG(J)*((DIAG(J)*WA1(J))/PNORM) IF (RATIO .GE. P0001) QTF(J) = SUM 280 CONTINUE C C COMPUTE THE QR FACTORIZATION OF THE UPDATED JACOBIAN. C CALL R1UPDT(N,N,R,LR,WA1,WA2,WA3,SING) CALL R1MPYQ(N,N,FJAC,LDFJAC,WA2,WA3) CALL R1MPYQ(1,N,QTF,1,WA2,WA3) C C END OF THE INNER LOOP. C JEVAL = .FALSE. GO TO 180 290 CONTINUE C C END OF THE OUTER LOOP. C GO TO 30 300 CONTINUE C C TERMINATION, EITHER NORMAL OR USER IMPOSED. C IF (IFLAG .LT. 0) INFO = IFLAG IFLAG = 0 IF (NPRINT .GT. 0) CALL FCN(N,X,FVEC,IFLAG) RETURN C C LAST CARD OF SUBROUTINE HYBRD. C END SUBROUTINE QDCRT (A, Z) C----------------------------------------------------------------------- C C QDCRT COMPUTES THE ROOTS OF THE REAL POLYNOMIAL C A(1) + A(2)*Z + A(3)*Z**2 C AND STORES THE RESULTS IN Z. IT IS ASSUMED THAT A(3) C IS NONZERO. C C----------------------------------------------------------------------- REAL A(3) COMPLEX Z(2) C----------------------------------------------------------------------- C C ***** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE C SMALLEST NUMBER SUCH THAT 1.0 + EPS .GT. 1.0. C EPS = SPMPAR(1) C C------------------- IF (A(1) .EQ. 0.0) GO TO 40 D = A(2)*A(2) - 4.0*A(1)*A(3) IF (ABS(D) .LE. 2.0*EPS*A(2)*A(2)) GO TO 20 R = SQRT(ABS(D)) IF (D .LT. 0.0) GO TO 30 C C DISTINCT REAL ROOTS C IF (A(2) .NE. 0.0) GO TO 10 X = ABS(0.5*R/A(3)) Z(1) = CMPLX(X, 0.0) Z(2) = CMPLX(-X, 0.0) RETURN 10 W = -(A(2) + SIGN(R,A(2))) Z(1) = CMPLX(2.0*A(1)/W, 0.0) Z(2) = CMPLX(0.5*W/A(3), 0.0) RETURN C C EQUAL REAL ROOTS C 20 Z(1) = CMPLX(-0.5*A(2)/A(3), 0.0) Z(2) = Z(1) RETURN C C COMPLEX ROOTS C 30 X = -0.5*A(2)/A(3) Y = ABS(0.5*R/A(3)) Z(1) = CMPLX(X, Y) Z(2) = CMPLX(X,-Y) RETURN C C CASE WHEN A(1) = 0 C 40 Z(1) = (0.0, 0.0) Z(2) = CMPLX(-A(2)/A(3), 0.0) RETURN END SUBROUTINE DQDCRT (A, ZR, ZI) C----------------------------------------------------------------------- C C DQDCRT COMPUTES THE ROOTS OF THE REAL POLYNOMIAL C A(1) + A(2)*Z + A(3)*Z**2 C AND STORES THE RESULTS IN ZR AND ZI. IT IS ASSUMED THAT C A(3) IS NONZERO. C C----------------------------------------------------------------------- DOUBLE PRECISION A(3), ZR(3), ZI(3) DOUBLE PRECISION D, EPS, R, W DOUBLE PRECISION DPMPAR C----------------------------------------------------------------------- C C ***** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE C SMALLEST NUMBER SUCH THAT 1.D0 + EPS .GT. 1.D0. C EPS = DPMPAR(1) C C------------------- IF (A(1) .EQ. 0.D0) GO TO 40 D = A(2)*A(2) - 4.D0*A(1)*A(3) IF (DABS(D) .LE. 2.D0*EPS*A(2)*A(2)) GO TO 20 R = DSQRT(DABS(D)) IF (D .LT. 0.D0) GO TO 30 C C DISTINCT REAL ROOTS C ZI(1) = 0.D0 ZI(2) = 0.D0 IF (A(2) .NE. 0.D0) GO TO 10 ZR(1) = DABS(0.5D0*R/A(3)) ZR(2) = -ZR(1) RETURN 10 W = -(A(2) + DSIGN(R,A(2))) ZR(1) = 2.D0*A(1)/W ZR(2) = 0.5D0*W/A(3) RETURN C C EQUAL REAL ROOTS C 20 ZR(1) = -0.5D0*A(2)/A(3) ZR(2) = ZR(1) ZI(1) = 0.D0 ZI(2) = 0.D0 RETURN C C COMPLEX ROOTS C 30 ZR(1) = -0.5D0*A(2)/A(3) ZR(2) = ZR(1) ZI(1) = DABS(0.5D0*R/A(3)) ZI(2) = -ZI(1) RETURN C C CASE WHEN A(1) = 0 C 40 ZR(1) = 0.D0 ZR(2) = -A(2)/A(3) ZI(1) = 0.D0 ZI(2) = 0.D0 RETURN END SUBROUTINE CBCRT (A, Z) C----------------------------------------------------------------------- C C CBCRT COMPUTES THE ROOTS OF THE REAL POLYNOMIAL C A(1) + A(2)*Z + A(3)*Z**2 + A(4)*Z**3 C AND STORES THE RESULTS IN Z. IT IS ASSUMED THAT A(4) C IS NONZERO. C C----------------------------------------------------------------------- C WRITTEN BY ALFRED H. MORRIS C NAVAL SURFACE WEAPONS CENTER C DAHLGREN, VIRGINIA C----------------------------------------------------------------------- REAL A(4), AQ(3) COMPLEX Z(3) C------------------- DATA RT3/1.7320508075689/ C----------------------------------------------------------------------- C C ***** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE C SMALLEST NUMBER SUCH THAT 1.0 + EPS .GT. 1.0. C EPS = SPMPAR(1) C C------------------- IF (A(1) .EQ. 0.0) GO TO 100 P = A(3)/(3.0*A(4)) Q = A(2)/A(4) R = A(1)/A(4) TOL = 4.0*EPS C C = 0.0 T = A(2) - P*A(3) IF (ABS(T) .GT. TOL*ABS(A(2))) C = T/A(4) C T = 2.0*P*P - Q IF (ABS(T) .LE. TOL*ABS(Q)) T = 0.0 D = R + P*T IF (ABS(D) .LE. TOL*ABS(R)) GO TO 110 C C SET SQ = (A(4)/S)**2 * (C**3/27 + D**2/4) C S = AMAX1(ABS(A(1)),ABS(A(2)),ABS(A(3))) P1 = A(3)/(3.0*S) Q1 = A(2)/S R1 = A(1)/S C T1 = Q - 2.25*P*P IF (ABS(T1) .LE. TOL*ABS(Q)) T1 = 0.0 W = 0.25*R1*R1 W1 = 0.5*P1*R1*T W2 = Q1*Q1*T1/27.0 IF (W1 .LT. 0.0) GO TO 10 W = W + W1 SQ = W + W2 GO TO 12 10 IF (W2 .LT. 0.0) GO TO 11 W = W + W2 SQ = W + W1 GO TO 12 11 SQ = W + (W1 + W2) 12 IF (ABS(SQ) .LE. TOL*W) SQ = 0.0 RQ = ABS(S/A(4))*SQRT(ABS(SQ)) IF (SQ .GE. 0.0) GO TO 40 C C ALL ROOTS ARE REAL C ARG = ATAN2(RQ, -0.5*D) CF = COS(ARG/3.0) SF = SIN(ARG/3.0) RT = SQRT(-C/3.0) Y1 = 2.0*RT*CF Y2 = -RT*(CF + RT3*SF) Y3 = -(D/Y1)/Y2 C X1 = Y1 - P X2 = Y2 - P X3 = Y3 - P IF (ABS(X1) .LE. ABS(X2)) GO TO 20 T = X1 X1 = X2 X2 = T 20 IF (ABS(X2) .LE. ABS(X3)) GO TO 30 T = X2 X2 = X3 X3 = T IF (ABS(X1) .LE. ABS(X2)) GO TO 30 T = X1 X1 = X2 X2 = T C 30 W = X3 IF (ABS(X2) .LT. 0.1*ABS(X3)) GO TO 70 IF (ABS(X1) .LT. 0.1*ABS(X2)) X1 = - (R/X3)/X2 Z(1) = CMPLX(X1, 0.0) Z(2) = CMPLX(X2, 0.0) Z(3) = CMPLX(X3, 0.0) RETURN C C REAL AND COMPLEX ROOTS C 40 RA = CBRT(-0.5*D - SIGN(RQ,D)) RB = -C/(3.0*RA) T = RA + RB W = -P X = -P IF (ABS(T) .LE. TOL*ABS(RA)) GO TO 41 W = T - P X = -0.5*T - P IF (ABS(X) .LE. TOL*ABS(P)) X = 0.0 41 T = ABS(RA - RB) Y = 0.5*RT3*T C IF (T .LE. TOL*ABS(RA)) GO TO 60 IF (ABS(X) .LT. ABS(Y)) GO TO 50 S = ABS(X) T = Y/X GO TO 51 50 S = ABS(Y) T = X/Y 51 IF (S .LT. 0.1*ABS(W)) GO TO 70 W1 = W/S SUM = 1.0 + T*T IF (W1*W1 .LT. 0.01*SUM) W = - ((R/SUM)/S)/S Z(1) = CMPLX(W,0.0) Z(2) = CMPLX(X, Y) Z(3) = CMPLX(X,-Y) RETURN C C AT LEAST TWO ROOTS ARE EQUAL C 60 IF (ABS(X) .LT. ABS(W)) GO TO 61 IF (ABS(W) .LT. 0.1*ABS(X)) W = - (R/X)/X Z(1) = CMPLX(W, 0.0) Z(2) = CMPLX(X, 0.0) Z(3) = Z(2) RETURN 61 IF (ABS(X) .LT. 0.1*ABS(W)) GO TO 70 Z(1) = CMPLX(X, 0.0) Z(2) = Z(1) Z(3) = CMPLX(W, 0.0) RETURN C C HERE W IS MUCH LARGER IN MAGNITUDE THAN THE OTHER ROOTS. C AS A RESULT, THE OTHER ROOTS MAY BE EXCEEDINGLY INACCURATE C BECAUSE OF ROUNDOFF ERROR. TO DEAL WITH THIS, A QUADRATIC C IS FORMED WHOSE ROOTS ARE THE SAME AS THE SMALLER ROOTS OF C THE CUBIC. THIS QUADRATIC IS THEN SOLVED. C C THIS CODE WAS WRITTEN BY WILLIAM L. DAVIS (NSWC). C 70 AQ(1) = A(1) AQ(2) = A(2) + A(1)/W AQ(3) = -A(4)*W CALL QDCRT(AQ, Z) Z(3) = CMPLX(W, 0.0) C IF (AIMAG(Z(1)) .EQ. 0.0) RETURN Z(3) = Z(2) Z(2) = Z(1) Z(1) = CMPLX(W, 0.0) RETURN C----------------------------------------------------------------------- C C CASE WHEN A(1) = 0 C 100 Z(1) = (0.0, 0.0) CALL QDCRT(A(2), Z(2)) RETURN C C CASE WHEN D = 0 C 110 Z(1) = CMPLX(-P, 0.0) W = SQRT(ABS(C)) IF (C .LT. 0.0) GO TO 120 Z(2) = CMPLX(-P, W) Z(3) = CMPLX(-P,-W) RETURN C 120 IF (P .NE. 0.0) GO TO 130 Z(2) = CMPLX(W, 0.0) Z(3) = CMPLX(-W, 0.0) RETURN C 130 X = -(P + SIGN(W,P)) Z(3) = CMPLX(X, 0.0) T = 3.0*A(1)/(A(3)*X) IF (ABS(P) .GT. ABS(T)) GO TO 131 Z(2) = CMPLX(T, 0.0) RETURN 131 Z(2) = Z(1) Z(1) = CMPLX(T, 0.0) RETURN END SUBROUTINE DCBCRT (A, ZR, ZI) C----------------------------------------------------------------------- C C DCBCRT COMPUTES THE ROOTS OF THE REAL POLYNOMIAL C A(1) + A(2)*Z + A(3)*Z**2 + A(4)*Z**3 C AND STORES THE RESULTS IN ZR AND ZI. IT IS ASSUMED THAT C A(4) IS NONZERO. C C----------------------------------------------------------------------- C WRITTEN BY ALFRED H. MORRIS C NAVAL SURFACE WEAPONS CENTER C DAHLGREN, VIRGINIA C----------------------------------------------------------------------- DOUBLE PRECISION A(4), ZR(3), ZI(3) DOUBLE PRECISION AQ(3), ARG, C, CF, D, EPS, P, P1, Q, Q1, * R, RA, RB, RQ, RT, RT3, R1, S, SF, SQ, SUM, * T, TOL, T1, W, W1, W2, X, X1, X2, X3, Y, * Y1, Y2, Y3 DOUBLE PRECISION DPMPAR, DCBRT C------------------- DATA RT3 /1.732050807568877293527446341505872366943D0/ C----------------------------------------------------------------------- C C ***** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE C SMALLEST NUMBER SUCH THAT 1.D0 + EPS .GT. 1.D0. C EPS = DPMPAR(1) C C------------------- IF (A(1) .EQ. 0.D0) GO TO 100 P = A(3)/(3.D0*A(4)) Q = A(2)/A(4) R = A(1)/A(4) TOL = 4.D0*EPS C C = 0.D0 T = A(2) - P*A(3) IF (DABS(T) .GT. TOL*DABS(A(2))) C = T/A(4) C T = 2.D0*P*P - Q IF (DABS(T) .LE. TOL*DABS(Q)) T = 0.D0 D = R + P*T IF (DABS(D) .LE. TOL*DABS(R)) GO TO 110 C C SET SQ = (A(4)/S)**2 * (C**3/27 + D**2/4) C S = DMAX1(DABS(A(1)),DABS(A(2)),DABS(A(3))) P1 = A(3)/(3.D0*S) Q1 = A(2)/S R1 = A(1)/S C T1 = Q - 2.25D0*P*P IF (DABS(T1) .LE. TOL*DABS(Q)) T1 = 0.D0 W = 0.25D0*R1*R1 W1 = 0.5D0*P1*R1*T W2 = Q1*Q1*T1/27.D0 IF (W1 .LT. 0.D0) GO TO 10 W = W + W1 SQ = W + W2 GO TO 12 10 IF (W2 .LT. 0.D0) GO TO 11 W = W + W2 SQ = W + W1 GO TO 12 11 SQ = W + (W1 + W2) 12 IF (DABS(SQ) .LE. TOL*W) SQ = 0.D0 RQ = DABS(S/A(4))*DSQRT(DABS(SQ)) IF (SQ .GE. 0.D0) GO TO 40 C C ALL ROOTS ARE REAL C ARG = DATAN2(RQ, -0.5D0*D) CF = DCOS(ARG/3.D0) SF = DSIN(ARG/3.D0) RT = DSQRT(-C/3.D0) Y1 = 2.D0*RT*CF Y2 = -RT*(CF + RT3*SF) Y3 = -(D/Y1)/Y2 C X1 = Y1 - P X2 = Y2 - P X3 = Y3 - P IF (DABS(X1) .LE. DABS(X2)) GO TO 20 T = X1 X1 = X2 X2 = T 20 IF (DABS(X2) .LE. DABS(X3)) GO TO 30 T = X2 X2 = X3 X3 = T IF (DABS(X1) .LE. DABS(X2)) GO TO 30 T = X1 X1 = X2 X2 = T C 30 W = X3 IF (DABS(X2) .LT. 0.1D0*DABS(X3)) GO TO 70 IF (DABS(X1) .LT. 0.1D0*DABS(X2)) X1 = - (R/X3)/X2 ZR(1) = X1 ZR(2) = X2 ZR(3) = X3 ZI(1) = 0.D0 ZI(2) = 0.D0 ZI(3) = 0.D0 RETURN C C REAL AND COMPLEX ROOTS C 40 RA = DCBRT(-0.5D0*D - DSIGN(RQ,D)) RB = -C/(3.D0*RA) T = RA + RB W = -P X = -P IF (DABS(T) .LE. TOL*DABS(RA)) GO TO 41 W = T - P X = -0.5D0*T - P IF (DABS(X) .LE. TOL*DABS(P)) X = 0.D0 41 T = DABS(RA - RB) Y = 0.5D0*RT3*T C IF (T .LE. TOL*DABS(RA)) GO TO 60 IF (DABS(X) .LT. DABS(Y)) GO TO 50 S = DABS(X) T = Y/X GO TO 51 50 S = DABS(Y) T = X/Y 51 IF (S .LT. 0.1D0*DABS(W)) GO TO 70 W1 = W/S SUM = 1.D0 + T*T IF (W1*W1 .LT. 1.D-2*SUM) W = - ((R/SUM)/S)/S ZR(1) = W ZR(2) = X ZR(3) = X ZI(1) = 0.D0 ZI(2) = Y ZI(3) = -Y RETURN C C AT LEAST TWO ROOTS ARE EQUAL C 60 ZI(1) = 0.D0 ZI(2) = 0.D0 ZI(3) = 0.D0 IF (DABS(X) .LT. DABS(W)) GO TO 61 IF (DABS(W) .LT. 0.1D0*DABS(X)) W = - (R/X)/X ZR(1) = W ZR(2) = X ZR(3) = X RETURN 61 IF (DABS(X) .LT. 0.1D0*DABS(W)) GO TO 70 ZR(1) = X ZR(2) = X ZR(3) = W RETURN C C HERE W IS MUCH LARGER IN MAGNITUDE THAN THE OTHER ROOTS. C AS A RESULT, THE OTHER ROOTS MAY BE EXCEEDINGLY INACCURATE C BECAUSE OF ROUNDOFF ERROR. TO DEAL WITH THIS, A QUADRATIC C IS FORMED WHOSE ROOTS ARE THE SAME AS THE SMALLER ROOTS OF C THE CUBIC. THIS QUADRATIC IS THEN SOLVED. C C THIS CODE WAS WRITTEN BY WILLIAM L. DAVIS (NSWC). C 70 AQ(1) = A(1) AQ(2) = A(2) + A(1)/W AQ(3) = -A(4)*W CALL DQDCRT (AQ, ZR, ZI) ZR(3) = W ZI(3) = 0.D0 C IF (ZI(1) .EQ. 0.D0) RETURN ZR(3) = ZR(2) ZI(3) = ZI(2) ZR(2) = ZR(1) ZI(2) = ZI(1) ZR(1) = W ZI(1) = 0.D0 RETURN C----------------------------------------------------------------------- C C CASE WHEN A(1) = 0 C 100 ZR(1) = 0.D0 ZI(1) = 0.D0 CALL DQDCRT(A(2), ZR(2), ZI(2)) RETURN C C CASE WHEN D = 0 C 110 ZR(1) = -P ZI(1) = 0.D0 W = DSQRT(DABS(C)) IF (C .LT. 0.D0) GO TO 120 ZR(2) = -P ZR(3) = ZR(2) ZI(2) = W ZI(3) = -W RETURN C 120 IF (P .NE. 0.D0) GO TO 130 ZR(2) = W ZR(3) = -W ZI(2) = 0.D0 ZI(3) = 0.D0 RETURN C 130 X = -(P + DSIGN(W,P)) ZR(3) = X ZI(2) = 0.D0 ZI(3) = 0.D0 T = 3.D0*A(1)/(A(3)*X) IF (DABS(P) .GT. DABS(T)) GO TO 131 ZR(2) = T RETURN 131 ZR(2) = ZR(1) ZR(1) = T RETURN END SUBROUTINE QTCRT (A, Z) C----------------------------------------------------------------------- C C QTCRT COMPUTES THE ROOTS OF THE REAL POLYNOMIAL C A(1) + A(2)*Z + ... + A(5)*Z**4 C AND STORES THE RESULTS IN Z. IT IS ASSUMED THAT A(5) C IS NONZERO. C C----------------------------------------------------------------------- C WRITTEN BY ALFRED H. MORRIS C NAVAL SURFACE WEAPONS CENTER C DAHLGREN, VIRGINIA C----------------------------------------------------------------------- REAL A(5), TEMP(4) COMPLEX Z(4), W C IF (A(1) .EQ. 0.0) GO TO 100 B = A(4)/(4.0*A(5)) C = A(3)/A(5) D = A(2)/A(5) E = A(1)/A(5) B2 = B*B C P = 0.5*(C - 6.0*B2) Q = D - 2.0*B*(C - 4.0*B2) R = B2*(C - 3.0*B2) - B*D + E C C SOLVE THE RESOLVENT CUBIC EQUATION. THE CUBIC HAS C AT LEAST ONE NONNEGATIVE REAL ROOT. IF W1, W2, W3 C ARE THE ROOTS OF THE CUBIC THEN THE ROOTS OF THE C ORIGINIAL EQUATION ARE C C Z = -B + CSQRT(W1) + CSQRT(W2) + CSQRT(W3) C C WHERE THE SIGNS OF THE SQUARE ROOTS ARE CHOSEN SO C THAT CSQRT(W1) * CSQRT(W2) * CSQRT(W3) = -Q/8. C TEMP(1) = -Q*Q/64.0 TEMP(2) = 0.25*(P*P - R) TEMP(3) = P TEMP(4) = 1.0 CALL CBCRT(TEMP,Z) IF (AIMAG(Z(2)) .NE. 0.0) GO TO 60 C C THE RESOLVENT CUBIC HAS ONLY REAL ROOTS C REORDER THE ROOTS IN INCREASING ORDER C X1 = REAL(Z(1)) X2 = REAL(Z(2)) X3 = REAL(Z(3)) IF (X1 .LE. X2) GO TO 10 T = X1 X1 = X2 X2 = T 10 IF (X2 .LE. X3) GO TO 20 T = X2 X2 = X3 X3 = T IF (X1 .LE. X2) GO TO 20 T = X1 X1 = X2 X2 = T C 20 U = 0.0 IF (X3 .GT. 0.0) U = SQRT(X3) IF (X2 .LE. 0.0) GO TO 41 IF (X1 .GE. 0.0) GO TO 30 IF (ABS(X1) .GT. X2) GO TO 40 X1 = 0.0 C 30 X1 = SQRT(X1) X2 = SQRT(X2) IF (Q .GT. 0.0) X1 = -X1 TEMP(1) = (( X1 + X2) + U) - B TEMP(2) = ((-X1 - X2) + U) - B TEMP(3) = (( X1 - X2) - U) - B TEMP(4) = ((-X1 + X2) - U) - B CALL AORD (TEMP,4) IF (ABS(TEMP(1)) .GE. 0.1*ABS(TEMP(4))) GO TO 31 T = TEMP(2)*TEMP(3)*TEMP(4) IF (T .NE. 0.0) TEMP(1) = E/T 31 Z(1) = CMPLX(TEMP(1), 0.0) Z(2) = CMPLX(TEMP(2), 0.0) Z(3) = CMPLX(TEMP(3), 0.0) Z(4) = CMPLX(TEMP(4), 0.0) RETURN C 40 V1 = SQRT(ABS(X1)) V2 = 0.0 GO TO 50 41 V1 = SQRT(ABS(X1)) V2 = SQRT(ABS(X2)) IF (Q .LT. 0.0) U = -U C 50 X = -U - B Y = V1 - V2 Z(1) = CMPLX(X, Y) Z(2) = CMPLX(X,-Y) X = U - B Y = V1 + V2 Z(3) = CMPLX(X, Y) Z(4) = CMPLX(X,-Y) RETURN C C THE RESOLVENT CUBIC HAS COMPLEX ROOTS C 60 T = REAL(Z(1)) X = 0.0 IF (T) 61,70,62 61 H = ABS(REAL(Z(2))) + ABS(AIMAG(Z(2))) IF (ABS(T) .LE. H) GO TO 70 GO TO 80 62 X = SQRT(T) IF (Q .GT. 0.0) X = -X C 70 W = CSQRT(Z(2)) U = 2.0*REAL(W) V = 2.0*ABS(AIMAG(W)) T = X - B X1 = T + U X2 = T - U IF (ABS(X1) .LE. ABS(X2)) GO TO 71 T = X1 X1 = X2 X2 = T 71 U = -X - B H = U*U + V*V IF (X1*X1 .LT. 0.01*AMIN1(X2*X2,H)) X1 = E/(X2*H) Z(1) = CMPLX(X1, 0.0) Z(2) = CMPLX(X2, 0.0) Z(3) = CMPLX(U, V) Z(4) = CMPLX(U,-V) RETURN C 80 V = SQRT(ABS(T)) Z(1) = CMPLX(-B, V) Z(2) = CMPLX(-B,-V) Z(3) = Z(1) Z(4) = Z(2) RETURN C C CASE WHEN A(1) = 0 C 100 Z(1) = (0.0, 0.0) CALL CBCRT(A(2), Z(2)) RETURN END SUBROUTINE DQTCRT (A, ZR, ZI) C----------------------------------------------------------------------- C C DQTCRT COMPUTES THE ROOTS OF THE REAL POLYNOMIAL C A(1) + A(2)*Z + ... + A(5)*Z**4 C AND STORES THE RESULTS IN ZR AND ZI. IT IS ASSUMED C THAT A(5) IS NONZERO. C C----------------------------------------------------------------------- C WRITTEN BY ALFRED H. MORRIS C NAVAL SURFACE WEAPONS CENTER C DAHLGREN, VIRGINIA C----------------------------------------------------------------------- DOUBLE PRECISION A(5), ZR(4), ZI(4) DOUBLE PRECISION B, B2, C, D, E, H, P, Q, R, T, TEMP(4), * U, V, V1, V2, W(2), X, X1, X2, X3 C IF (A(1) .EQ. 0.D0) GO TO 100 B = A(4)/(4.D0*A(5)) C = A(3)/A(5) D = A(2)/A(5) E = A(1)/A(5) B2 = B*B C P = 0.5D0*(C - 6.D0*B2) Q = D - 2.D0*B*(C - 4.D0*B2) R = B2*(C - 3.D0*B2) - B*D + E C C SOLVE THE RESOLVENT CUBIC EQUATION. THE CUBIC HAS C AT LEAST ONE NONNEGATIVE REAL ROOT. IF W1, W2, W3 C ARE THE ROOTS OF THE CUBIC THEN THE ROOTS OF THE C ORIGINIAL EQUATION ARE C C Z = -B + CSQRT(W1) + CSQRT(W2) + CSQRT(W3) C C WHERE THE SIGNS OF THE SQUARE ROOTS ARE CHOSEN SO C THAT CSQRT(W1) * CSQRT(W2) * CSQRT(W3) = -Q/8. C TEMP(1) = -Q*Q/64.D0 TEMP(2) = 0.25D0*(P*P - R) TEMP(3) = P TEMP(4) = 1.D0 CALL DCBCRT (TEMP, ZR, ZI) IF (ZI(2) .NE. 0.D0) GO TO 60 C C THE RESOLVENT CUBIC HAS ONLY REAL ROOTS C REORDER THE ROOTS IN INCREASING ORDER C X1 = ZR(1) X2 = ZR(2) X3 = ZR(3) IF (X1 .LE. X2) GO TO 10 T = X1 X1 = X2 X2 = T 10 IF (X2 .LE. X3) GO TO 20 T = X2 X2 = X3 X3 = T IF (X1 .LE. X2) GO TO 20 T = X1 X1 = X2 X2 = T C 20 U = 0.D0 IF (X3 .GT. 0.D0) U = DSQRT(X3) IF (X2 .LE. 0.D0) GO TO 41 IF (X1 .GE. 0.D0) GO TO 30 IF (DABS(X1) .GT. X2) GO TO 40 X1 = 0.D0 C 30 X1 = DSQRT(X1) X2 = DSQRT(X2) IF (Q .GT. 0.D0) X1 = -X1 ZR(1) = (( X1 + X2) + U) - B ZR(2) = ((-X1 - X2) + U) - B ZR(3) = (( X1 - X2) - U) - B ZR(4) = ((-X1 + X2) - U) - B CALL DAORD (ZR, 4) IF (DABS(ZR(1)) .GE. 0.1D0*DABS(ZR(4))) GO TO 31 T = ZR(2)*ZR(3)*ZR(4) IF (T .NE. 0.D0) ZR(1) = E/T 31 ZI(1) = 0.D0 ZI(2) = 0.D0 ZI(3) = 0.D0 ZI(4) = 0.D0 RETURN C 40 V1 = DSQRT(DABS(X1)) V2 = 0.D0 GO TO 50 41 V1 = DSQRT(DABS(X1)) V2 = DSQRT(DABS(X2)) IF (Q .LT. 0.D0) U = -U C 50 ZR(1) = -U - B ZI(1) = V1 - V2 ZR(2) = ZR(1) ZI(2) = -ZI(1) ZR(3) = U - B ZI(3) = V1 + V2 ZR(4) = ZR(3) ZI(4) = -ZI(3) RETURN C C THE RESOLVENT CUBIC HAS COMPLEX ROOTS C 60 T = ZR(1) X = 0.D0 IF (T) 61,70,62 61 H = DABS(ZR(2)) + DABS(ZI(2)) IF (DABS(T) .LE. H) GO TO 70 GO TO 80 62 X = DSQRT(T) IF (Q .GT. 0.D0) X = -X C 70 W(1) = ZR(2) W(2) = ZI(2) CALL DCSQRT (W, W) U = 2.D0*W(1) V = 2.D0*DABS(W(2)) T = X - B X1 = T + U X2 = T - U IF (DABS(X1) .LE. DABS(X2)) GO TO 71 T = X1 X1 = X2 X2 = T 71 U = -X - B H = U*U + V*V IF (X1*X1 .LT. 1.D-2*DMIN1(X2*X2,H)) X1 = E/(X2*H) ZR(1) = X1 ZR(2) = X2 ZI(1) = 0.D0 ZI(2) = 0.D0 ZR(3) = U ZR(4) = U ZI(3) = V ZI(4) = -V RETURN C 80 V = DSQRT(DABS(T)) ZR(1) = -B ZR(2) = -B ZR(3) = -B ZR(4) = -B ZI(1) = V ZI(2) = -V ZI(3) = V ZI(4) = -V RETURN C C CASE WHEN A(1) = 0 C 100 ZR(1) = 0.D0 ZI(1) = 0.D0 CALL DCBCRT(A(2), ZR(2), ZI(2)) RETURN END SUBROUTINE DRPOLY (OP, IDEG, ZEROR, ZEROI, NUM, WK, DWK) C C THIS SUBROUTINE FINDS THE ZEROS OF A REAL POLYNOMIAL. C C OP - DOUBLE PRECISION ARRAY OF LENGTH IDEG + 1. C ON INPUT THIS ARRAY CONTAINS THE COEFFICIENTS C IN ORDER OF DECREASING POWERS. C C IDEG - INTEGER DEGREE OF THE POLYNOMIAL. C C ZEROR,ZEROI - DOUBLE PRECISION ARRAYS IF LENGTH IDEG. C ON OUTPUT THESE ARRAYS CONTAIN THE REAL AND C IMAGINARY PARTS OF THE ZEROS. C C NUM - VARIABLE THAT REPORTS THE STATUS OF THE RESULTS. C IF NUM = -1 THEN THE LEADING COEFFICIENT OF THE C POLYNOMIAL IS 0 OR IDEG .LT. 1. OTHERWISE, NUM C IS THE NUMBER OF ZEROS THAT WERE OBTAINED. IF C NUM .GE. 1 THEN THE REAL AND IMAGINARY PARTS OF C THE ZEROS ARE STORED IN ZEROR(J) AND ZEROI(J) C FOR J = 1,...,NUM. C C WK - REAL ARRAY OF LENGTH IDEG + 1. THE ARRAY IS C A WORK SPACE FOR THE ROUTINE. C C DWK - DOUBLE PRECISION ARRAY OF LENGTH 6*(IDEG + 1). C THE ARRAY IS A WORK SPACE FOR THE ROUTINE. C C THE SUBROUTINE USES SINGLE PRECISION CALCULATIONS FOR SCALING, C BOUNDS, AND ERROR CALCULATIONS. ALL OTHER CALCULATIONS ARE DONE C IN DOUBLE PRECISION. C INTEGER IDEG, NUM DOUBLE PRECISION OP(*), ZEROR(IDEG), ZEROI(IDEG), DWK(*) REAL WK(*) C INTEGER P, QP, K, QK, SVK, TMP C IF (IDEG .LT. 1) GO TO 10 C C PARTITION THE WORKSPACE DWK AND OBTAIN THE ZEROS C IDP1 = IDEG + 1 C P = 1 QP = P + IDP1 K = QP + IDP1 QK = K + IDP1 SVK = QK + IDP1 TMP = SVK + IDP1 C CALL DRPLY1 (OP,IDEG,IDP1,ZEROR,ZEROI,DWK(P),DWK(QP),DWK(K), * DWK(QK),DWK(SVK),DWK(TMP),WK,NUM) RETURN C C ERROR RETURN C 10 NUM = -1 RETURN END SUBROUTINE DRPLY1 (OP,IDEG,IDP1,ZEROR,ZEROI,P,QP,K,QK,SVK, * TEMP,PT,NUM) C------------------------- DOUBLE PRECISION OP(IDP1), ZEROR(IDEG), ZEROI(IDEG), * P(IDP1), QP(IDP1), K(IDP1), QK(IDP1), * SVK(IDP1), TEMP(IDP1) REAL PT(IDP1) C DOUBLE PRECISION AA, BB, CC, FACTOR, T REAL LO, MAX, MIN, XX, YY, COSR, SINR, X, XXX, SC, * BND, XM, FF, DF, DX, BASE, SMALNO, INFIN INTEGER CNT LOGICAL ZEROK C REAL SPMPAR INTEGER IPMPAR DOUBLE PRECISION DPMPAR C------------------------- REAL ETA, ARE, MRE DOUBLE PRECISION SR, SI, U, V, A, B, C, D, A1, A2, A3, A6, A7, * E, F, G, H, SZR, SZI, LZR, LZI COMMON /GLOBAL/ SR, SI, U, V, A, B, C, D, A1, A2, A3, A6, A7, * E, F, G, H, SZR, SZI, LZR, LZI, ETA, ARE, MRE C------------------------- C THE FOLLOWING STATEMENTS SET THE MACHINE CONSTANTS USED C IN THE CODE. THE MEANING OF THE CONSTANTS ARE ... C C ETA THE SMALLEST POSITIVE NUMBER SUCH THAT C 1.D0 + ETA IS GREATER THAN 1.D0 C SMALNO THE SMALLEST POSITIVE FLOATING POINT NUMBER. C IF THE EXPONENT RANGE DIFFERS IN SINGLE AND C DOUBLE PRECISION THEN SMALNO AND INFIN C SHOULD INDICATE THE SMALLER RANGE. C INFIN THE LARGEST POSITIVE FLOATING POINT NUMBER. C BASE THE BASE OF THE FLOATING POINT ARITHMETICS C BEING USED. C ETA = DPMPAR(1) SMALNO = SPMPAR(2) INFIN = SPMPAR(3) BASE = IPMPAR(4) C------------------------- C C ARE AND MRE REFER TO THE UNIT ERROR IN + AND * C RESPECTIVELY. THEY ARE ASSUMED TO BE THE SAME AS ETA. C ARE = ETA MRE = ETA LO = SMALNO/ETA C C INITIALIZATION OF CONSTANTS FOR SHIFT ROTATION C XX = .70710678 YY = -XX COSR = -.069756474 SINR = .99756405 N = IDEG NN = IDP1 NUM = 0 C C ALGORITHM FAILS IF THE LEADING COEFFICIENT IS ZERO. C IF (OP(1) .NE. 0.D0) GO TO 10 NUM = -1 RETURN C C REMOVE THE ZEROS AT THE ORIGIN IF ANY C 10 IF (OP(NN) .NE. 0.0D0) GO TO 20 NUM = NUM + 1 ZEROR(NUM) = 0.D0 ZEROI(NUM) = 0.D0 NN = NN - 1 N = N - 1 GO TO 10 C C MAKE A COPY OF THE COEFFICIENTS C 20 DO 30 I = 1,NN P(I) = OP(I) 30 CONTINUE C C START THE ALGORITHM FOR OBTAINING A ZERO C 40 IF (N .GT. 2) GO TO 60 IF (N .LT. 1) RETURN C C CALCULATE THE FINAL ZERO OR PAIR OF ZEROS C NUM = IDEG IF (N .EQ. 2) GO TO 50 ZEROR(IDEG) = -P(2)/P(1) ZEROI(IDEG) = 0.0D0 RETURN 50 CALL QUADPL(P(1), P(2), P(3), ZEROR(IDEG - 1), ZEROI(IDEG - 1), * ZEROR(IDEG), ZEROI(IDEG)) RETURN C C FIND LARGEST AND SMALLEST MODULI OF COEFFICIENTS. C 60 MAX = 0.0 MIN = INFIN DO 70 I = 1,NN X = ABS(SNGL(P(I))) IF (X .GT. MAX) MAX = X IF (X .NE. 0.0 .AND. X .LT. MIN) MIN = X 70 CONTINUE C C SCALE IF THERE ARE LARGE OR VERY SMALL COEFFICIENTS. C COMPUTES A SCALE FACTOR TO MULTIPLY THE C COEFFICIENTS OF THE POLYNOMIAL. THE SCALING IS DONE C TO AVOID OVERFLOW AND TO AVOID UNDETECTED UNDERFLOW C INTERFERING WITH THE CONVERGENCE CRITERION. C THE FACTOR IS A POWER OF THE BASE. C SC = LO/MIN IF (SC .GT. 1.0) GO TO 80 IF (MAX .LT. 10.0) GO TO 110 IF (SC .EQ. 0.0) SC = SMALNO GO TO 90 80 IF (INFIN/SC .LT. MAX) GO TO 110 90 L = ALOG(SC)/ALOG(BASE) + 0.5 FACTOR = DBLE(BASE)**L IF (FACTOR .EQ. 1.D0) GO TO 110 DO 100 I = 1,NN P(I) = FACTOR*P(I) 100 CONTINUE C C COMPUTE LOWER BOUND ON MODULI OF ZEROS. C 110 DO 120 I=1,NN PT(I) = ABS(SNGL(P(I))) 120 CONTINUE PT(NN) = -PT(NN) C C COMPUTE UPPER ESTIMATE OF BOUND C X = EXP((ALOG(-PT(NN)) - ALOG(PT(1)))/FLOAT(N)) IF (PT(N) .EQ. 0.0) GO TO 130 C C IF THE NEWTON STEP AT THE ORIGIN IS BETTER THEN USE IT. C XM = -PT(NN)/PT(N) IF (XM .LT. X) X = XM C C CHOP THE INTERVAL (0,X) UNTIL FF .LE. 0. C 130 XM = X*.1 FF = PT(1) DO 140 I = 2,NN FF = FF*XM + PT(I) 140 CONTINUE IF (FF .LE. 0.0) GO TO 150 X = XM GO TO 130 150 DX = X C C DO NEWTON ITERATION UNTIL X CONVERGES TO TWO DECIMAL PLACES. C 160 IF (ABS(DX/X) .LE. 0.005) GO TO 180 FF = PT(1) DF = FF DO 170 I = 2,N FF = FF*X + PT(I) DF = DF*X + FF 170 CONTINUE FF = FF*X + PT(NN) DX = FF/DF X = X - DX GO TO 160 180 BND = X C C COMPUTE THE DERIVATIVE AS THE INTIAL K POLYNOMIAL C AND DO 5 STEPS WITH NO SHIFT. C NM1 = N - 1 DO 190 I = 2,N K(I) = FLOAT(NN - I)*P(I)/FLOAT(N) 190 CONTINUE K(1) = P(1) AA = P(NN) BB = P(N) ZEROK = K(N) .EQ. 0.D0 DO 230 JJ = 1,5 CC = K(N) IF (ZEROK) GO TO 210 C C USE SCALED FORM OF RECURRENCE IF VALUE OF K AT 0 IS NONZERO. C T = -AA/CC DO 200 I = 1,NM1 J = NN - I K(J) = T*K(J - 1) + P(J) 200 CONTINUE K(1) = P(1) ZEROK = DABS(K(N)) .LE. DABS(BB)*ETA*10. GO TO 230 C C USE UNSCALED FORM OF RECURRENCE C 210 DO 220 I = 1,NM1 J = NN - I K(J) = K(J - 1) 220 CONTINUE K(1) = 0.D0 ZEROK = K(N).EQ.0.D0 230 CONTINUE C C SAVE K FOR RESTARTS WITH NEW SHIFTS C DO 240 I = 1,N TEMP(I) = K(I) 240 CONTINUE C C LOOP TO SELECT THE QUADRATIC CORRESPONDING TO EACH C NEW SHIFT C DO 260 CNT = 1,20 C C QUADRATIC CORRESPONDS TO A DOUBLE SHIFT TO A C NON-REAL POINT AND ITS COMPLEX CONJUGATE. THE POINT C HAS MODULUS BND AND AMPLITUDE ROTATED BY 94 DEGREES C FROM THE PREVIOUS SHIFT. C XXX = COSR*XX - SINR*YY YY = SINR*XX + COSR*YY XX = XXX SR = BND*XX SI = BND*YY U = -2.0D0*SR V = BND C C SECOND STAGE CALCULATION, FIXED QUADRATIC. THE SECOND STAGE C JUMPS DIRECTLY TO ONE OF THE THIRD STAGE ITERATIONS. C CALL FXSHFR(20*CNT, NZ, NN, P, QP, K, QK, SVK) IF (NZ .NE. 0) GO TO 300 C C IF THE ITERATION IS UNSUCCESSFUL ANOTHER QUADRATIC C IS CHOSEN AFTER RESTORING K. C DO 250 I = 1,N K(I) = TEMP(I) 250 CONTINUE 260 CONTINUE C C CONVERGENCE WAS NOT ACHIEVED AFTER 20 SHIFTS. C RETURN C C STORE THE ZEROS OBTAINED AND DEFLATE THE POLYNOMIAL. C 300 NUM = NUM + 1 ZEROR(NUM) = SZR ZEROI(NUM) = SZI NN = NN - NZ N = NN - 1 DO 310 I = 1,NN P(I) = QP(I) 310 CONTINUE IF (NZ .EQ. 1) GO TO 40 NUM = NUM + 1 ZEROR(NUM) = LZR ZEROI(NUM) = LZI GO TO 40 END SUBROUTINE FXSHFR(L2, NZ, NN, P, QP, K, QK, SVK) C C COMPUTES UP TO L2 FIXED SHIFT K-POLYNOMIALS, C TESTING FOR CONVERGENCE IN THE LINEAR OR QUADRATIC C CASE. INITIATES ONE OF THE VARIABLE SHIFT C ITERATIONS AND RETURNS WITH THE NUMBER OF ZEROS C FOUND. C C L2 - LIMIT OF FIXED SHIFT STEPS C NZ - NUMBER OF ZEROS FOUND C DOUBLE PRECISION P(NN), QP(NN), K(NN), QK(NN), SVK(NN) DOUBLE PRECISION SVU, SVV, UI, VI, S REAL BETAS, BETAV, OSS, OVV, SS, VV, TS, TV, OTS, OTV, * TVV, TSS INTEGER L2, NZ, TYPE, I, J, IFLAG LOGICAL VPASS, SPASS, VTRY, STRY C REAL ETA, ARE, MRE DOUBLE PRECISION SR, SI, U, V, A, B, C, D, A1, A2, A3, A6, A7, * E, F, G, H, SZR, SZI, LZR, LZI COMMON /GLOBAL/ SR, SI, U, V, A, B, C, D, A1, A2, A3, A6, A7, * E, F, G, H, SZR, SZI, LZR, LZI, ETA, ARE, MRE C N = NN - 1 NZ = 0 BETAV = .25 BETAS = .25 OSS = SR OVV = V C C EVALUATE POLYNOMIAL BY SYNTHETIC DIVISION C CALL QUADSD(NN, U, V, P, QP, A, B) CALL CALCSC(TYPE, N, K, QK) DO 80 J = 1,L2 C C CALCULATE NEXT K POLYNOMIAL AND ESTIMATE V C CALL NEXTK(TYPE, N, QP, K, QK) CALL CALCSC(TYPE, N, K, QK) CALL NEWEST(TYPE, UI, VI, NN, P, K) VV = VI C C ESTIMATE S C SS = 0.0 IF (K(N) .NE. 0.D0) SS = -P(NN)/K(N) TV = 1.0 TS = 1.0 IF (J .EQ. 1 .OR. TYPE .EQ. 3) GO TO 70 C C COMPUTE RELATIVE MEASURES OF CONVERGENCE OF S AND V C SEQUENCES C IF (VV .NE. 0.0) TV = ABS((VV - OVV)/VV) IF (SS .NE. 0.0) TS = ABS((SS - OSS)/SS) C C IF DECREASING, MULTIPLY TWO MOST RECENT C CONVERGENCE MEASURES C TVV = 1.0 IF (TV .LT. OTV) TVV = TV*OTV TSS = 1.0 IF (TS .LT. OTS) TSS = TS*OTS C C COMPARE WITH CONVERGENCE CRITERIA C VPASS = TVV.LT.BETAV SPASS = TSS.LT.BETAS IF (.NOT.(SPASS .OR. VPASS)) GO TO 70 C C AT LEAST ONE SEQUENCE HAS PASSED THE CONVERGENCE C TEST. STORE VARIABLES BEFORE ITERATING C SVU = U SVV = V DO 10 I = 1,N SVK(I) = K(I) 10 CONTINUE S = SS C C CHOOSE ITERATION ACCORDING TO THE FASTEST C CONVERGING SEQUENCE C VTRY = .FALSE. STRY = .FALSE. IF (SPASS .AND. ((.NOT.VPASS) .OR. * TSS .LT. TVV)) GO TO 40 20 CALL QUADIT(UI, VI, NZ, NN, P, QP, K, QK) IF (NZ .GT. 0) RETURN C C QUADRATIC ITERATION HAS FAILED. FLAG THAT IT HAS C BEEN TRIED AND DECREASE THE CONVERGENCE CRITERION. C VTRY = .TRUE. BETAV = BETAV*0.25 C C TRY LINEAR ITERATION IF IT HAS NOT BEEN TRIED AND C THE S SEQUENCE IS CONVERGING C IF (STRY .OR. (.NOT.SPASS)) GO TO 50 DO 30 I = 1,N K(I) = SVK(I) 30 CONTINUE 40 CALL REALIT(S, NZ, IFLAG, NN, P, QP, K, QK) IF (NZ .GT. 0) RETURN C C LINEAR ITERATION HAS FAILED. FLAG THAT IT HAS BEEN C TRIED AND DECREASE THE CONVERGENCE CRITERION C STRY = .TRUE. BETAS = BETAS*0.25 IF (IFLAG .EQ. 0) GO TO 50 C C IF LINEAR ITERATION SIGNALS AN ALMOST DOUBLE REAL C ZERO ATTEMPT QUADRATIC INTERATION C UI = -(S + S) VI = S*S GO TO 20 C C RESTORE VARIABLES C 50 U = SVU V = SVV DO 60 I=1,N K(I) = SVK(I) 60 CONTINUE C C TRY QUADRATIC ITERATION IF IT HAS NOT BEEN TRIED C AND THE V SEQUENCE IS CONVERGING C IF (VPASS .AND. (.NOT.VTRY)) GO TO 20 C C RECOMPUTE QP AND SCALAR VALUES TO CONTINUE THE C SECOND STAGE C CALL QUADSD(NN, U, V, P, QP, A, B) CALL CALCSC(TYPE, N, K, QK) 70 OVV = VV OSS = SS OTV = TV OTS = TS 80 CONTINUE RETURN END SUBROUTINE QUADIT(UU, VV, NZ, NN, P, QP, K, QK) C C VARIABLE-SHIFT K-POLYNOMIAL ITERATION FOR A C QUADRATIC FACTOR CONVERGES ONLY IF THE ZEROS ARE C EQUIMODULAR OR NEARLY SO. C C UU,VV - COEFFICIENTS OF STARTING QUADRATIC C NZ - NUMBER OF ZERO FOUND C DOUBLE PRECISION UU, VV, P(NN), QP(NN), K(NN), QK(NN) DOUBLE PRECISION UI, VI REAL MP, OMP, EE, RELSTP, T, ZM INTEGER NZ, TYPE, I, J LOGICAL TRIED C REAL ETA, ARE, MRE DOUBLE PRECISION SR, SI, U, V, A, B, C, D, A1, A2, A3, A6, A7, * E, F, G, H, SZR, SZI, LZR, LZI COMMON /GLOBAL/ SR, SI, U, V, A, B, C, D, A1, A2, A3, A6, A7, * E, F, G, H, SZR, SZI, LZR, LZI, ETA, ARE, MRE C N = NN - 1 NZ = 0 TRIED = .FALSE. U = UU V = VV J = 0 C MAIN LOOP 10 CALL QUADPL(1.D0, U, V, SZR, SZI, LZR, LZI) C C RETURN IF ROOTS OF THE QUADRATIC ARE REAL AND NOT CLOSE C TO MULTIPLE OR NEARLY EQUAL AND OF OPPOSITE SIGN C IF (DABS(DABS(SZR) - DABS(LZR)) .GT. 1.D-2*DABS(LZR)) * RETURN C C EVALUATE POLYNOMIAL BY QUADRATIC SYNTHETIC DIVISION C CALL QUADSD(NN, U, V, P, QP, A, B) MP = DABS(A - SZR*B) + DABS(SZI*B) C C COMPUTE A RIGOROUS BOUND ON THE ROUNDING ERROR IN C EVALUTING P C ZM = SQRT(ABS(SNGL(V))) EE = 2.0*ABS(SNGL(QP(1))) T = -SZR*B DO 20 I = 2,N EE = EE*ZM + ABS(SNGL(QP(I))) 20 CONTINUE EE = EE*ZM + ABS(SNGL(A) + T) EE = (5.0*MRE + 4.0*ARE)*EE - (5.0*MRE + 2.0*ARE)* * (ABS(SNGL(A) + T) + ABS(SNGL(B))*ZM) + * 2.0*ARE*ABS(T) C C ITERATION HAS CONVERGED SUFFICIENTLY IF THE C POLYNOMIAL VALUE IS LESS THAN 20 TIMES THIS BOUND C IF (MP .GT. 20.0*EE) GO TO 30 NZ = 2 RETURN 30 J = J + 1 C C STOP ITERATION AFTER 20 STEPS C IF (J .GT. 20) RETURN IF (J .LT. 2) GO TO 50 IF (RELSTP .GT. 0.01 .OR. MP .LT. OMP .OR. TRIED) GO TO 50 C C A CLUSTER APPEARS TO BE STALLING THE CONVERGENCE. C FIVE FIXED SHIFT STEPS ARE TAKEN WITH A U,V CLOSE C TO THE CLUSTER C IF (RELSTP .LT. ETA) RELSTP = ETA RELSTP = SQRT(RELSTP) U = U - U*RELSTP V = V + V*RELSTP CALL QUADSD(NN, U, V, P, QP, A, B) DO 40 I = 1,5 CALL CALCSC(TYPE, N, K, QK) CALL NEXTK(TYPE, N, QP, K, QK) 40 CONTINUE TRIED = .TRUE. J = 0 50 OMP = MP C C CALCULATE NEXT K POLYNOMIAL AND NEW U AND V C CALL CALCSC(TYPE, N, K, QK) CALL NEXTK(TYPE, N, QP, K, QK) CALL CALCSC(TYPE, N, K, QK) CALL NEWEST(TYPE, UI, VI, NN, P, K) C C IF VI IS ZERO THE ITERATION IS NOT CONVERGING C IF (VI .EQ. 0.D0) RETURN RELSTP = DABS((VI - V)/VI) U = UI V = VI GO TO 10 END SUBROUTINE REALIT(SSS, NZ, IFLAG, NN, P, QP, K, QK) C C VARIABLE-SHIFT H POLYNOMIAL ITERATION FOR A REAL ZERO. C C SSS - STARTING ITERATE C NZ - NUMBER OF ZERO FOUND C IFLAG - FLAG TO INDICATE A PAIR OF ZEROS NEAR THE REAL C AXIS. C DOUBLE PRECISION SSS, P(NN), QP(NN), K(NN), QK(NN) DOUBLE PRECISION PV, KV, T, S REAL MS, MP, OMP, EE C REAL ETA, ARE, MRE DOUBLE PRECISION SR, SI, U, V, A, B, C, D, A1, A2, A3, A6, A7, * E, F, G, H, SZR, SZI, LZR, LZI COMMON /GLOBAL/ SR, SI, U, V, A, B, C, D, A1, A2, A3, A6, A7, * E, F, G, H, SZR, SZI, LZR, LZI, ETA, ARE, MRE C N = NN - 1 NZ = 0 S = SSS IFLAG = 0 J = 0 C C EVALUATE P AT S C 10 PV = P(1) QP(1) = PV DO 20 I = 2,NN PV = PV*S + P(I) QP(I) = PV 20 CONTINUE MP = DABS(PV) C C COMPUTE A RIGOROUS BOUND ON THE ERROR IN EVALUATING P C MS = DABS(S) EE = (MRE/(ARE+MRE))*ABS(SNGL(QP(1))) DO 30 I = 2,NN EE = EE*MS + ABS(SNGL(QP(I))) 30 CONTINUE C C ITERATION HAS CONVERGED SUFFICIENTLY IF THE C POLYNOMIAL VALUE IS LESS THAN 20 TIMES THIS BOUND C IF (MP .GT. 20.0*((ARE + MRE)*EE - MRE*MP)) GO TO 40 NZ = 1 SZR = S SZI = 0.D0 RETURN 40 J = J + 1 C C STOP ITERATION AFTER 10 STEPS C IF (J .GT. 10) RETURN IF (J .LT. 2) GO TO 50 IF (DABS(T) .GT. 1.D-3*DABS(S-T) .OR. MP .LE. OMP) * GO TO 50 C C A CLUSTER OF ZEROS NEAR THE REAL AXIS HAS BEEN C ENCOUNTERED RETURN WITH IFLAG SET TO INITIATE A C QUADRATIC ITERATION C IFLAG = 1 SSS = S RETURN C C RETURN IF THE POLYNOMIAL VALUE HAS INCREASED C SIGNIFICANTLY C 50 OMP = MP C C COMPUTE T, THE NEXT POLYNOMIAL, AND THE NEW ITERATE C KV = K(1) QK(1) = KV DO 60 I = 2,N KV = KV*S + K(I) QK(I) = KV 60 CONTINUE IF (DABS(KV) .LE. DABS(K(N))*10.*ETA) GO TO 80 C C USE THE SCALED FORM OF THE RECURRENCE IF THE VALUE C OF K AT S IS NONZERO C T = -PV/KV K(1) = QP(1) DO 70 I = 2,N K(I) = T*QK(I-1) + QP(I) 70 CONTINUE GO TO 100 C C USE UNSCALED FORM C 80 K(1) = 0.0D0 DO 90 I = 2,N K(I) = QK(I-1) 90 CONTINUE 100 KV = K(1) DO 110 I = 2,N KV = KV*S + K(I) 110 CONTINUE T = 0.D0 IF (DABS(KV) .GT. DABS(K(N))*10.*ETA) T = -PV/KV S = S + T GO TO 10 END SUBROUTINE CALCSC(TYPE, N, K, QK) C C THIS ROUTINE CALCULATES SCALAR QUANTITIES USED TO C COMPUTE THE NEXT K POLYNOMIAL AND NEW ESTIMATES OF C THE QUADRATIC COEFFICIENTS. C C TYPE - INTEGER VARIABLE SET HERE INDICATING HOW THE C CALCULATIONS ARE NORMALIZED TO AVOID OVERFLOW C INTEGER TYPE DOUBLE PRECISION K(N), QK(N) DOUBLE PRECISION TOL C REAL ETA, ARE, MRE DOUBLE PRECISION SR, SI, U, V, A, B, C, D, A1, A2, A3, A6, A7, * E, F, G, H, SZR, SZI, LZR, LZI COMMON /GLOBAL/ SR, SI, U, V, A, B, C, D, A1, A2, A3, A6, A7, * E, F, G, H, SZR, SZI, LZR, LZI, ETA, ARE, MRE C C SYNTHETIC DIVISION OF K BY THE QUADRATIC 1,U,V C CALL QUADSD(N, U, V, K, QK, C, D) TOL = 100.0*ETA IF (DABS(C) .GT. TOL*DABS(K(N))) GO TO 10 IF (DABS(D) .GT. TOL*DABS(K(N - 1))) GO TO 10 TYPE = 3 C C TYPE=3 INDICATES THE QUADRATIC IS ALMOST A FACTOR OF K C RETURN 10 IF (DABS(D) .LT. DABS(C)) GO TO 20 TYPE = 2 C C TYPE=2 INDICATES THAT ALL FORMULAS ARE DIVIDED BY D C E = A/D F = C/D G = U*B H = V*B A3 = (A + G)*E + H*(B/D) A1 = B*F - A A7 = (F + U)*A + H RETURN 20 TYPE = 1 C C TYPE=1 INDICATES THAT ALL FORMULAS ARE DIVIDED BY C C E = A/C F = D/C G = U*E H = V*B A3 = A*E + (H/C + G)*B A1 = B - A*(D/C) A7 = A + G*D + H*F RETURN END SUBROUTINE NEXTK(TYPE, N, QP, K, QK) C C COMPUTES THE NEXT K POLYNOMIALS USING THE SCALARS C COMPUTED IN CALCSC. C INTEGER TYPE DOUBLE PRECISION QP(N), K(N), QK(N) DOUBLE PRECISION TEMP REAL ETA, ARE, MRE DOUBLE PRECISION SR, SI, U, V, A, B, C, D, A1, A2, A3, A6, A7, * E, F, G, H, SZR, SZI, LZR, LZI COMMON /GLOBAL/ SR, SI, U, V, A, B, C, D, A1, A2, A3, A6, A7, * E, F, G, H, SZR, SZI, LZR, LZI, ETA, ARE, MRE C IF (TYPE .EQ. 3) GO TO 40 TEMP = A IF (TYPE .EQ. 1) TEMP = B IF (DABS(A1) .GT. DABS(TEMP)*ETA*10.) GO TO 20 C C IF A1 IS NEARLY ZERO THEN USE A SPECIAL FORM OF THE C RECURRENCE C K(1) = 0.D0 K(2) = -A7*QP(1) DO 10 I = 3,N K(I) = A3*QK(I-2) - A7*QP(I-1) 10 CONTINUE RETURN C C USE SCALED FORM OF THE RECURRENCE C 20 A7 = A7/A1 A3 = A3/A1 K(1) = QP(1) K(2) = QP(2) - A7*QP(1) DO 30 I = 3,N K(I) = A3*QK(I-2) - A7*QP(I-1) + QP(I) 30 CONTINUE RETURN C C USE UNSCALED FORM OF THE RECURRENCE IF TYPE IS 3 C 40 K(1) = 0.D0 K(2) = 0.D0 DO 50 I = 3,N K(I) = QK(I - 2) 50 CONTINUE RETURN END SUBROUTINE NEWEST (TYPE, UU, VV, NN, P, K) C C COMPUTE NEW ESTIMATES OF THE QUADRATIC COEFFICIENTS C USING THE SCALARS COMPUTED IN CALCSC. C INTEGER TYPE DOUBLE PRECISION UU, VV, P(NN), K(NN) DOUBLE PRECISION A4, A5, B1, B2, C1, C2, C3, C4, TEMP C REAL ETA, ARE, MRE DOUBLE PRECISION SR, SI, U, V, A, B, C, D, A1, A2, A3, A6, A7, * E, F, G, H, SZR, SZI, LZR, LZI COMMON /GLOBAL/ SR, SI, U, V, A, B, C, D, A1, A2, A3, A6, A7, * E, F, G, H, SZR, SZI, LZR, LZI, ETA, ARE, MRE C C USE FORMULAS APPROPRIATE TO SETTING OF TYPE. C N = NN - 1 IF (TYPE .EQ. 3) GO TO 30 IF (TYPE .EQ. 2) GO TO 10 A4 = A + U*B + H*F A5 = C + (U + V*F)*D GO TO 20 10 A4 = (A + G)*F + H A5 = (F + U)*C + V*D C C EVALUATE NEW QUADRATIC COEFFICIENTS. C 20 B1 = -K(N)/P(NN) B2 = -(K(N - 1) + B1*P(N))/P(NN) C1 = V*B2*A1 C2 = B1*A7 C3 = B1*B1*A3 C4 = C1 - C2 - C3 TEMP = A5 + B1*A4 - C4 IF (TEMP .EQ. 0.D0) GO TO 30 UU = U - (U*(C3 + C2) + V*(B1*A1 + B2*A7))/TEMP VV = V*(1.D0 + C4/TEMP) RETURN C C IF TYPE=3 THE QUADRATIC IS ZEROED C 30 UU = 0.D0 VV = 0.D0 RETURN END SUBROUTINE QUADSD (NN, U, V, P, Q, A, B) C C DIVIDES P BY THE QUADRATIC 1,U,V PLACING THE C QUOTIENT IN Q AND THE REMAINDER IN A,B. C DOUBLE PRECISION P(NN), Q(NN), U, V, A, B, C C B = P(1) Q(1) = B A = P(2) - U*B Q(2) = A DO 10 I = 3,NN C = P(I) - U*A - V*B Q(I) = C B = A A = C 10 CONTINUE RETURN END SUBROUTINE QUADPL(A, B1, C, SR, SI, LR, LI) C C CALCULATE THE ZEROS OF THE QUADRATIC A*Z**2+B1*Z+C. C THE QUADRATIC FORMULA, MODIFIED TO AVOID OVERFLOW, C IS USED TO FIND THE LARGER ZERO IF THE ZEROS ARE C REAL, AND BOTH ZEROS IF THE ZEROS ARE COMPLEX. C THE SMALLER REAL ZERO IS FOUND DIRECTLY FROM THE C PRODUCT OF THE ZEROS C/A. C DOUBLE PRECISION A, B1, C, SR, SI, LR, LI, B, D, E C IF (A .NE. 0.D0) GO TO 20 SR = 0.D0 IF (B1 .NE. 0.D0) SR = -C/B1 LR = 0.D0 10 SI = 0.D0 LI = 0.D0 RETURN C 20 IF (C .NE. 0.D0) GO TO 30 SR = 0.D0 LR = -B1/A GO TO 10 C C COMPUTE DISCRIMINANT AVOIDING OVERFLOW C 30 B = B1/2.D0 IF (DABS(B) .LT. DABS(C)) GO TO 40 E = 1.D0 - (A/B)*(C/B) D = DSQRT(DABS(E))*DABS(B) GO TO 50 40 E = A IF (C .LT. 0.D0) E = -A E = B*(B/DABS(C)) - E D = DSQRT(DABS(E))*DSQRT(DABS(C)) 50 IF (E .LT. 0.D0) GO TO 60 C C REAL ZEROS C IF (B .GE. 0.D0) D = -D LR = (-B + D)/A SR = 0.D0 IF (LR .NE. 0.D0) SR = (C/LR)/A GO TO 10 C C COMPLEX CONJUGATE ZEROS C 60 SR = -B/A LR = SR SI = DABS(D/A) LI = -SI RETURN END SUBROUTINE DCPOLY (OPR,OPI,IDEG,ZEROR,ZEROI,NUM,WK) C C THIS SUBROUTINE FINDS THE ZEROS OF A COMPLEX POLYNOMIAL. C C OPR,OPI - DOUBLE PRECISION ARRAYS OF LENGTH IDEG + 1. C ON INPUT THESE ARRAYS CONTAIN THE REAL AND IMAGINARY C PARTS OF THE COEFFICIENTS IN ORDER OF DECREASING C POWERS. C C IDEG - INTEGER DEGREE OF THE POLYNOMIAL. C C ZEROR,ZEROI - DOUBLE PRECISION ARRAYS OF LENGTH IDEG. C ON OUTPUT THESE ARRAYS CONTAIN THE REAL AND C IMAGINARY PARTS OF THE ZEROS. C C NUM - VARIABLE THAT REPORTS THE STATUS OF THE RESULTS. C IF NUM = -1 THEN THE LEADING COEFFICIENT OF THE C POLYNOMIAL IS 0 OR IDEG .LT. 1. OTHERWISE, NUM C IS THE NUMBER OF ZEROS THAT WERE OBTAINED. IF C NUM .GE. 1 THEN THE REAL AND IMAGINARY PARTS OF C THE ZEROS ARE STORED IN ZEROR(J) AND ZEROI(J) C FOR J = 1,...,NUM. C C WK - DOUBLE PRECISION ARRAY OF LENGTH 10*(IDEG + 1). C THE ARRAY IS A WORK SPACE FOR THE ROUTINE. C C THE CODE HAS BEEN WRITTEN TO REDUCE THE CHANCE OF OVERFLOW C OCCURRING. IF IT DOES OCCUR, THERE IS STILL A POSSIBILITY THAT C THE ZEROFINDER WILL WORK PROVIDED THE OVERFLOWED QUANTITY IS C REPLACED BY A LARGE NUMBER. C INTEGER IDEG DOUBLE PRECISION OPR(*),OPI(*),ZEROR(IDEG),ZEROI(IDEG),WK(*) C INTEGER PR,PI,QPR,QPI,HR,HI,QHR,QHI,SHR,SHI C IF (IDEG .LT. 1) GO TO 10 C C PARTITION THE WORKSPACE AND OBTAIN THE ZEROS C IDP1 = IDEG + 1 C PR = 1 PI = PR + IDP1 QPR = PI + IDP1 QPI = QPR + IDP1 HR = QPI + IDP1 HI = HR + IDP1 QHR = HI + IDP1 QHI = QHR + IDP1 SHR = QHI + IDP1 SHI = SHR + IDP1 C CALL DCPLY1 (OPR,OPI,IDEG,IDP1,ZEROR,ZEROI,WK(PR),WK(PI), * WK(QPR),WK(QPI),WK(HR),WK(HI),WK(QHR),WK(QHI), * WK(SHR),WK(SHI),NUM) RETURN C C ERROR RETURN C 10 NUM = -1 RETURN END SUBROUTINE DCPLY1 (OPR,OPI,IDEG,IDP1,ZEROR,ZEROI,PR,PI,QPR,QPI, * HR,HI,QHR,QHI,SHR,SHI,NUM) C------------------------- DOUBLE PRECISION OPR(IDP1),OPI(IDP1),ZEROR(IDEG),ZEROI(IDEG), * PR(IDP1),PI(IDP1),QPR(IDP1),QPI(IDP1), * HR(IDP1),HI(IDP1),QHR(IDP1),QHI(IDP1), * SHR(IDP1),SHI(IDP1) DOUBLE PRECISION SR,SI,TR,TI,PVR,PVI,ARE,MRE,ETA,INFIN DOUBLE PRECISION XX,YY,COSR,SINR,SMALNO,BASE,XXX,ZR,ZI,BND, * DCPABS,DPMPAR,SCALCP LOGICAL CONV INTEGER CNT1,CNT2 C------------------------- C THE FOLLOWING STATEMENTS SET THE MACHINE CONSTANTS USED C IN THE CODE. THE MEANING OF THE CONSTANTS ARE ... C C ETA THE SMALLEST POSITIVE NUMBER SUCH THAT C 1.D0 + ETA IS GREATER THAN 1.D0 C SMALNO THE SMALLEST POSITIVE FLOATING POINT NUMBER. C INFIN THE LARGEST POSITIVE FLOATING POINT NUMBER. C BASE THE BASE OF THE FLOATING POINT ARITHMETIC C BEING USED. C ETA = DPMPAR(1) SMALNO = DPMPAR(2) INFIN = DPMPAR(3) BASE = IPMPAR(4) C------------------------- C C INITIALIZATION C ARE = ETA MRE = 2.D0*DSQRT(2.D0)*ETA XX = .70710678 YY = -XX COSR = -.069756474 SINR = .99756405 NUM = 0 NN = IDP1 C C THE ALGORITHM FAILS IF THE LEADING COEFFICIENT IS ZERO C IF (OPR(1) .NE. 0.D0 .OR. OPI(1) .NE. 0.D0) GO TO 10 NUM = -1 RETURN C C REMOVE THE ZEROS AT THE ORIGIN IF ANY. C 10 IF (OPR(NN) .NE. 0.D0 .OR. OPI(NN) .NE. 0.D0) GO TO 20 NUM = NUM + 1 ZEROR(NUM) = 0.D0 ZEROI(NUM) = 0.D0 NN = NN - 1 GO TO 10 C C MAKE A COPY OF THE COEFFICIENTS. C 20 IF (NN .LT. 2) RETURN DO 30 I = 1,NN PR(I) = OPR(I) PI(I) = OPI(I) SHR(I) = DCPABS(PR(I),PI(I)) 30 CONTINUE C C SCALE THE POLYNOMIAL. C BND = SCALCP (NN,SHR,ETA,INFIN,SMALNO,BASE) IF (BND .EQ. 1.D0) GO TO 40 DO 35 I = 1,NN PR(I) = BND*PR(I) PI(I) = BND*PI(I) 35 CONTINUE C C START THE ALGORITHM FOR OBTAINING A ZERO. C 40 IF (NN .GT. 2) GO TO 50 C NUM = IDEG CALL CDIVID(-PR(2),-PI(2),PR(1),PI(1),ZEROR(IDEG), * ZEROI(IDEG)) RETURN C C CALCULATE BND, A LOWER BOUND ON THE MODULUS OF THE ZEROS. C 50 DO 60 I = 1,NN SHR(I) = DCPABS(PR(I),PI(I)) 60 CONTINUE CALL CAUCHY(NN,BND,SHR,SHI) C C OUTER LOOP TO CONTROL TWO MAJOR PASSES WITH DIFFERENT C SEQUENCES OF SHIFTS. C DO 80 CNT1 = 1,2 C C FIRST STAGE CALCULATION. NO SHIFT. C CALL NOSHFT(5,NN,TR,TI,ETA,PR,PI,HR,HI) C C INNER LOOP TO SELECT A SHIFT. C DO 70 CNT2 = 1,9 C C THE SHIFT IS CHOSEN WITH MODULUS BND AND AMPLITUDE ROTATED C BY 94 DEGREES FROM THE PREVIOUS SHIFT. C XXX = COSR*XX - SINR*YY YY = SINR*XX + COSR*YY XX = XXX SR = BND*XX SI = BND*YY C C SECOND STAGE CALCULATION, FIXED SHIFT. THE SECOND STAGE JUMPS C DIRECTLY TO THE THIRD STAGE ITERATION. C CALL FXSHFT(10*CNT2,ZR,ZI,CONV,NN,PR,PI,HR,HI,QPR,QPI, * QHR,QHI,SHR,SHI,SR,SI,TR,TI,PVR,PVI, * ARE,MRE,ETA,INFIN) IF (CONV) GO TO 100 C C IF THE ITERATION IS UNSUCCESSFUL ANOTHER SHIFT IS CHOSEN. C 70 CONTINUE C C IF 9 SHIFTS FAIL, THE OUTER LOOP IS REPEATED WITH ANOTHER C SEQUENCE OF SHIFTS. C 80 CONTINUE RETURN C C A ZERO HAS BEEN OBTAINED. STORE THE ZERO AND DEFLATE C THE POLYNOMIAL. C 100 NUM = NUM + 1 ZEROR(NUM) = ZR ZEROI(NUM) = ZI NN = NN - 1 DO 110 I = 1,NN PR(I) = QPR(I) PI(I) = QPI(I) 110 CONTINUE GO TO 40 END DOUBLE PRECISION FUNCTION SCALCP(NN,PT,ETA,INFIN,SMALNO,BASE) C C RETURNS A SCALE FACTOR TO MULTIPLY THE COEFFICIENTS OF THE C POLYNOMIAL. THE SCALING IS DONE TO AVOID OVERFLOW AND TO AVOID C UNDETECTED UNDERFLOW INTERFERING WITH THE CONVERGENCE CRITERION. C THE FACTOR IS A POWER OF THE BASE. C C PT - MODULUS OF THE COEFFICIENTS OF P C ETA,INFIN,SMALNO,BASE - CONSTANTS DESCRIBING THE C FLOATING POINT ARITHMETIC. C DOUBLE PRECISION PT(NN),ETA,INFIN,SMALNO,BASE,HI,LO, * MAX,MIN,X,SC C C FIND THE LARGEST AND SMALLEST MODULI OF COEFFICIENTS. C HI = DSQRT(INFIN) LO = SMALNO/ETA MAX = 0.D0 MIN = INFIN DO 10 I = 1,NN X = PT(I) IF (X .GT. MAX) MAX = X IF (X .NE. 0.D0 .AND. X .LT. MIN) MIN = X 10 CONTINUE C C SCALE ONLY IF THERE ARE VERY LARGE OR VERY SMALL COEFFICIENTS. C SCALCP = 1.D0 SC = LO/MIN IF (SC .GT. 1.D0) GO TO 20 IF (MAX .LE. HI) RETURN SC = 1.D0/(DSQRT(MAX)*DSQRT(MIN)) GO TO 30 20 IF (INFIN/SC .LT. MAX) RETURN 30 L = DLOG(SC)/DLOG(BASE) + 0.5D0 SCALCP = BASE**L RETURN END SUBROUTINE CAUCHY(NN,BND,PT,Q) C C CAUCHY COMPUTES A LOWER BOUND BND ON THE MODULI OF THE ZEROS C OF A POLYNOMIAL. PT IS THE MODULUS OF THE COEFFICIENTS. C DOUBLE PRECISION Q(NN),PT(NN),X,XM,F,DX,DF,BND C PT(NN) = -PT(NN) C C COMPUTE UPPER ESTIMATE OF BOUND. C N = NN - 1 X = DEXP((DLOG(-PT(NN)) - DLOG(PT(1)))/DBLE(FLOAT(N))) IF (PT(N) .EQ. 0.D0) GO TO 20 C C IF THE NEWTON STEP AT THE ORIGIN IS BETTER THEN USE IT. C XM = -PT(NN)/PT(N) IF (XM .LT. X) X = XM C C CHOP THE INTERVAL (0,X) UNTIL F .LE. 0. C 20 XM = 0.1D0*X F = PT(1) DO 30 I = 2,NN F = F*XM + PT(I) 30 CONTINUE IF (F .LE. 0.D0) GO TO 40 X = XM GO TO 20 40 DX = X C C DO NEWTON ITERATION UNTIL X CONVERGES TO TWO DECIMAL PLACES. C 50 IF (DABS(DX/X) .LE. 0.005D0) GO TO 70 Q(1) = PT(1) DO 60 I = 2,NN Q(I) = Q(I - 1)*X + PT(I) 60 CONTINUE F = Q(NN) DF = Q(1) DO 65 I = 2,N DF = DF*X + Q(I) 65 CONTINUE DX = F/DF X = X - DX GO TO 50 C 70 BND = X RETURN END SUBROUTINE NOSHFT(L1,NN,TR,TI,ETA,PR,PI,HR,HI) C C COMPUTES THE DERIVATIVE POLYNOMIAL AS THE INITIAL H C POLYNOMIAL AND COMPUTES L1 NO-SHIFT H POLYNOMIALS. C DOUBLE PRECISION TR,TI,ETA,PR(NN),PI(NN),HR(NN),HI(NN) DOUBLE PRECISION DN,T1,T2,XNI,DCPABS C N = NN - 1 NM1 = N - 1 DN = N DO 10 I = 1,N XNI = NN - I HR(I) = XNI*PR(I)/DN HI(I) = XNI*PI(I)/DN 10 CONTINUE C DO 50 JJ = 1,L1 IF (DCPABS(HR(N),HI(N)) .LE. 10.D0*ETA*DCPABS(PR(N),PI(N))) * GO TO 30 CALL CDIVID(-PR(NN),-PI(NN),HR(N),HI(N),TR,TI) DO 20 I = 1,NM1 J = NN - I T1 = HR(J - 1) T2 = HI(J - 1) HR(J) = TR*T1 - TI*T2 + PR(J) HI(J) = TR*T2 + TI*T1 + PI(J) 20 CONTINUE HR(1) = PR(1) HI(1) = PI(1) GO TO 50 C C IF THE CONSTANT TERM IS ESSENTIALLY ZERO, SHIFT H COEFFICIENTS. C 30 DO 40 I = 1,NM1 J = NN - I HR(J) = HR(J - 1) HI(J) = HI(J - 1) 40 CONTINUE HR(1) = 0.D0 HI(1) = 0.D0 50 CONTINUE RETURN END SUBROUTINE FXSHFT(L2,ZR,ZI,CONV,NN,PR,PI,HR,HI,QPR,QPI, * QHR,QHI,SHR,SHI,SR,SI,TR,TI,PVR,PVI, * ARE,MRE,ETA,INFIN) C C COMPUTES L2 FIXED-SHIFT H POLYNOMIALS AND TESTS FOR CONVERGENCE. C INITIATES A VARIABLE-SHIFT ITERATION AND RETURNS WITH THE C APPROXIMATE ZERO IF SUCCESSFUL. C C L2 - LIMIT OF FIXED-SHIFT STEPS C ZR,ZI - APPROXIMATE ZERO IF CONV IS .TRUE. C CONV - LOGICAL VARIABLE INDICATING CONVERGENCE OF STAGE 3 C ITERATION C DOUBLE PRECISION SR,SI,TR,TI,PVR,PVI,ARE,MRE,ETA,INFIN, * PR(NN),PI(NN),QPR(NN),QPI(NN),HR(NN),HI(NN), * QHR(NN),QHI(NN),SHR(NN),SHI(NN) DOUBLE PRECISION ZR,ZI,OTR,OTI,SVSR,SVSI,DCPABS LOGICAL CONV,TEST,PASD,BOOL C N = NN - 1 C C EVALUATE P AT S C CALL POLYEV(NN,SR,SI,PR,PI,QPR,QPI,PVR,PVI) TEST = .TRUE. PASD = .FALSE. C C CALCULATE T = -P(S)/H(S) C CALL CALCT(BOOL,N,SR,SI,TR,TI,PVR,PVI,ARE,HR,HI,QHR,QHI) C C MAIN LOOP FOR ONE SECOND STAGE STEP. C DO 50 J = 1,L2 OTR = TR OTI = TI C C COMPUTE NEXT H POLYNOMIAL AND NEW T. C CALL NEXTH(BOOL,N,TR,TI,HR,HI,QPR,QPI,QHR,QHI) CALL CALCT(BOOL,N,SR,SI,TR,TI,PVR,PVI,ARE,HR,HI,QHR,QHI) ZR = SR + TR ZI = SI + TI C C TEST FOR CONVERGENCE UNLESS STAGE 3 HAS FAILED ONCE OR THIS C IS THE LAST H POLYNOMIAL. C IF (BOOL .OR. (.NOT. TEST) .OR. J .EQ. L2) GO TO 50 IF (DCPABS(TR - OTR,TI - OTI) .GE. 0.5D0*DCPABS(ZR,ZI)) * GO TO 40 IF (.NOT. PASD) GO TO 30 C C THE WEAK CONVERGENCE TEST HAS BEEN PASSED TWICE. START THE C THIRD SHIFT ITERATION AFTER SAVING THE CURRENT H POLYNOMIAL C AND SHIFT. C DO 10 I = 1,N SHR(I) = HR(I) SHI(I) = HI(I) 10 CONTINUE SVSR = SR SVSI = SI CALL VRSHFT(10,ZR,ZI,CONV,NN,PR,PI,HR,HI,QPR,QPI,QHR, * QHI,SR,SI,TR,TI,PVR,PVI,ARE,MRE,ETA,INFIN) IF (CONV) RETURN C C THE ITERATION FAILED TO CONVERGE. TURN OFF TESTING AND RESTORE C H,S,PV AND T. C TEST = .FALSE. DO 20 I = 1,N HR(I) = SHR(I) HI(I) = SHI(I) 20 CONTINUE SR = SVSR SI = SVSI CALL POLYEV(NN,SR,SI,PR,PI,QPR,QPI,PVR,PVI) CALL CALCT(BOOL,N,SR,SI,TR,TI,PVR,PVI,ARE,HR,HI,QHR,QHI) GO TO 50 C 30 PASD = .TRUE. GO TO 50 C 40 PASD = .FALSE. 50 CONTINUE C C ATTEMPT AN ITERATION WITH FINAL H POLYNOMIAL FROM SECOND STAGE. C CALL VRSHFT(10,ZR,ZI,CONV,NN,PR,PI,HR,HI,QPR,QPI,QHR,QHI, * SR,SI,TR,TI,PVR,PVI,ARE,MRE,ETA,INFIN) RETURN END SUBROUTINE VRSHFT(L3,ZR,ZI,CONV,NN,PR,PI,HR,HI,QPR,QPI,QHR,QHI, * SR,SI,TR,TI,PVR,PVI,ARE,MRE,ETA,INFIN) C C CARRIES OUT THE THIRD STAGE ITERATION. C C L3 - LIMIT OF STEPS IN STAGE 3. C ZR,ZI - ON ENTRY CONTAIN THE INITIAL ITERATE. IF THE C ITERATION CONVERGES ZR,ZI CONTAIN THE FINAL C ITERATE ON EXIT. C CONV - THE VALUE IS .TRUE. IF THE ITERATION CONVERGES. C DOUBLE PRECISION SR,SI,TR,TI,PVR,PVI,ARE,MRE,ETA,INFIN, * PR(NN),PI(NN),QPR(NN),QPI(NN),HR(NN),HI(NN), * QHR(NN),QHI(NN) DOUBLE PRECISION ZR,ZI,MP,MS,OMP,RELSTP,R1,R2,TP,ERREV,DCPABS LOGICAL CONV,B,BOOL C CONV = .FALSE. B = .FALSE. SR = ZR SI = ZI N = NN - 1 C C MAIN LOOP FOR STAGE 3. C DO 60 I = 1,L3 C C EVALUATE P AT S AND TEST FOR CONVERGENCE. C CALL POLYEV(NN,SR,SI,PR,PI,QPR,QPI,PVR,PVI) MP = DCPABS(PVR,PVI) MS = DCPABS(SR,SI) IF (MP .GT. 20.D0*ERREV(NN,QPR,QPI,MS,MP,ARE,MRE)) * GO TO 10 C C POLYNOMIAL VALUE IS SMALLER THAN A BOUND ON THE ERROR C IN EVALUATING P. TERMINATE THE ITERATION. C CONV = .TRUE. ZR = SR ZI = SI RETURN C 10 IF (I .EQ. 1) GO TO 40 IF (B .OR. MP .LT. OMP .OR. RELSTP .GE. 0.05D0) * GO TO 30 C C ITERATION HAS STALLED. PROBABLY A CLUSTER OF ZEROS. DO 5 FIXED C SHIFT STEPS INTO THE CLUSTER TO FORCE ONE ZERO TO DOMINATE. C TP = RELSTP B = .TRUE. IF (RELSTP .LT. ETA) TP = ETA R1 = DSQRT(TP) R2 = SR*(1.D0 + R1) - SI*R1 SI = SR*R1 + SI*(1.D0 + R1) SR = R2 CALL POLYEV(NN,SR,SI,PR,PI,QPR,QPI,PVR,PVI) DO 20 J = 1,5 CALL CALCT(BOOL,N,SR,SI,TR,TI,PVR,PVI,ARE,HR,HI,QHR,QHI) CALL NEXTH(BOOL,N,TR,TI,HR,HI,QPR,QPI,QHR,QHI) 20 CONTINUE OMP = INFIN GO TO 50 C C EXIT IF THE POLYNOMIAL VALUE INCREASES SIGNIFICANTLY. C 30 IF (0.1D0*MP .GT. OMP) RETURN C C CALCULATE THE NEXT ITERATE. C 40 OMP = MP C 50 CALL CALCT(BOOL,N,SR,SI,TR,TI,PVR,PVI,ARE,HR,HI,QHR,QHI) CALL NEXTH(BOOL,N,TR,TI,HR,HI,QPR,QPI,QHR,QHI) CALL CALCT(BOOL,N,SR,SI,TR,TI,PVR,PVI,ARE,HR,HI,QHR,QHI) IF (BOOL) GO TO 60 RELSTP = DCPABS(TR,TI)/DCPABS(SR,SI) SR = SR + TR SI = SI + TI 60 CONTINUE RETURN END SUBROUTINE CALCT(BOOL,N,SR,SI,TR,TI,PVR,PVI,ARE,HR,HI,QHR,QHI) C C THIS SUBROUTINE COMPUTES T = -P(S)/H(S) C C BOOL - LOGICAL VARIABLE, WHICH IS SET TO .TRUE. IF H(S) IS C ESSENTIALLY ZERO. C LOGICAL BOOL DOUBLE PRECISION SR,SI,TR,TI,PVR,PVI,ARE,HR(N),HI(N), * QHR(N),QHI(N) DOUBLE PRECISION HVR,HVI,DCPABS C C EVALUATE H(S) C CALL POLYEV (N,SR,SI,HR,HI,QHR,QHI,HVR,HVI) BOOL = DCPABS(HVR,HVI) .LE. 10.D0*ARE*DCPABS(HR(N),HI(N)) IF (BOOL) GO TO 10 CALL CDIVID(-PVR,-PVI,HVR,HVI,TR,TI) RETURN 10 TR = 0.D0 TI = 0.D0 RETURN END SUBROUTINE NEXTH(BOOL,N,TR,TI,HR,HI,QPR,QPI,QHR,QHI) C C CALCULATES THE NEXT SHIFTED H POLYNOMIAL. C C BOOL - LOGICAL VARIABLE. IF .TRUE. H(S) IS ESSENTIALLY ZERO. C LOGICAL BOOL DOUBLE PRECISION TR,TI,HR(N),HI(N),QPR(N),QPI(N),QHR(N),QHI(N) DOUBLE PRECISION T1,T2 C IF (BOOL) GO TO 20 DO 10 J = 2,N T1 = QHR(J - 1) T2 = QHI(J - 1) HR(J) = TR*T1 - TI*T2 + QPR(J) HI(J) = TR*T2 + TI*T1 + QPI(J) 10 CONTINUE HR(1) = QPR(1) HI(1) = QPI(1) RETURN C C IF H(S) IS ZERO THEN REPLACE H WITH QH. C 20 DO 30 J = 2,N HR(J) = QHR(J - 1) HI(J) = QHI(J - 1) 30 CONTINUE HR(1) = 0.D0 HI(1) = 0.D0 RETURN END SUBROUTINE POLYEV(N,SR,SI,PR,PI,QR,QI,PVR,PVI) C C EVALUATES A POLYNOMIAL P AT S BY THE HORNER RECURRENCE ALGO., C PLACING THE PARTIAL SUMS IN Q AND THE COMPUTED VALUE IN PV. C DOUBLE PRECISION PR(N),PI(N),QR(N),QI(N),SR,SI,PVR,PVI,T C QR(1) = PR(1) QI(1) = PI(1) PVR = QR(1) PVI = QI(1) DO 10 I = 2,N T = PVR*SR - PVI*SI + PR(I) PVI = PVR*SI + PVI*SR + PI(I) PVR = T QR(I) = PVR QI(I) = PVI 10 CONTINUE RETURN END DOUBLE PRECISION FUNCTION ERREV(NN,QR,QI,MS,MP,ARE,MRE) C C BOUNDS THE ERROR IN EVALUATING THE POLYNOMIAL BY THE HORNER C RECURRENCE ALGORITHM. C C QR,QI - THE PARTIAL SUMS C MS - MODULUS OF THE POINT C MP - MODULUS OF THE POLYNOMIAL VALUE C ARE,MRE - ERROR BOUNDS ON COMPLEX ADDITION AND MULTIPLICATION C DOUBLE PRECISION QR(NN),QI(NN),MS,MP,ARE,MRE,E,DCPABS C E = DCPABS(QR(1),QI(1))*MRE/(ARE + MRE) DO 10 I = 1,NN E = E*MS + DCPABS(QR(I),QI(I)) 10 CONTINUE ERREV = E*(ARE + MRE) - MP*MRE RETURN END SUBROUTINE RBND (N, C, W, ABSERR, RELERR, KLUST, KER) C----------------------------------------------------------------------- C C ABSTRACT C C THIS ROUTINE COMPUTES ERROR BOUNDS AND CLUSTER COUNTS C FOR APPROXIMATE ZEROS OF A POLYNOMIAL WITH REAL COEFFICIENTS. C THE ZEROS MAY HAVE BEEN COMPUTED BY ANY APPROPRIATE ROUTINE. C THE METHOD USED IS BASED ON THE FACT THAT THE VALUE OF A C POLYNOMIAL AT ANY POINT IS EQUAL TO THE LEADING COEFFICIENT C TIMES THE PRODUCT OF THE DISTANCES FROM THAT POINT TO EACH C OF THE ZEROS. GIVEN THE VALUE OF THE POLYNOMIAL AT AN C APPROXIMATE ZERO, RBND COMPUTES FOR EACH APPROXIMATE ZERO C THE RADIUS OF A CIRCLE ABOUT THAT APPROXIMATE ZERO WHICH C CONTAINS A TRUE ZERO OF THE POLYNOMIAL. USING THE KNOWN C DISTRIBUTION OF APPROXIMATE ZEROS, AN ITERATIVE PROCEDURE C IS USED TO SHRINK THE RADII OF THE CIRCLES. C C DESCRIPTION OF ARGUMENTS C C INPUT--- C C N - DEGREE OF THE POLYNOMIAL (NUMBER OF ZEROS). C C - REAL ARRAY OF N+1 COEFFICIENTS OF THE POLYNOMIAL C C(1) + C(2)*Z + ... + C(N+1)*Z**N C W - COMPLEX ARRAY OF N APPROXIMATE ZEROS. C C OUTPUT-- C C ABSERR - REAL ARRAY OF N ABSOLUTE ERROR BOUNDS. ABSERR(I) IS C THE ABSOLUTE ERROR BOUND IN THE ZERO (WR(I),WI(I)). C RELERR - REAL ARRAY OF N RELATIVE ERROR BOUNDS. RELERR(I) IS C THE RELATIVE ERROR BOUND IN THE ZERO (WR(I),WI(I)). C KLUST - INTEGER ARRAY OF CLUSTER COUNTS FOR ZEROS. THE TRUE C ZERO CORRESPONDING TO I-TH APPROXIMATE ZERO LIES IN C A CIRCLE OF RADIUS ABSERR(I). KLUST(I) IS THE NUMBER C OF CIRCLES INCLUDING THE I-TH CIRCLE WHICH OVERLAP C THE I-TH CIRCLE. THE CLUSTER COUNT OFTEN INDICATES C THE MULTIPLICITY OF A ZERO. C KER - AN ERROR FLAG C --NORMAL CODE C 0 MEANS THE BOUNDS AND COUNTS WERE COMPUTED. C --ABNORMAL CODES C 1 N (DEGREE) MUST BE .GE. 1 C 2 LEADING COEFFICIENT IS ZERO C C------------------- C WRITTEN BY CARL B. BAILEY AND MODIFIED BY WILLIAM R. GAVIN C SANDIA LABORATORIES C ALBUQUERQUE, NEW MEXICO C JANUARY 1976 C MODIFIED BY A.H. MORRIS (NSWC) C----------------------------------------------------------------------- COMPLEX W(N), Z INTEGER KLUST(N) REAL C(*), ABSERR(N), RELERR(N) DOUBLE PRECISION XR, XI, VR, VI, VT LOGICAL SHRUNK C----------------------------------------------------------------------- C C ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE C SMALLEST NUMBER SUCH THAT 1 + EPS .GT. 1. C EPS = SPMPAR(1) C C----------------------------------------------------------------------- IF (N .LT. 1) GO TO 200 NP1 = N + 1 POWER = 1.0/FLOAT(N) P = ABS(C(NP1)) IF (P .EQ. 0.0) GO TO 210 RAT = 4.0*EPS*ABS(C(1))/P C DO 20 L = 1,N XR = REAL(W(L)) XI = AIMAG(W(L)) VR = C(NP1) VI = 0.0D0 DO 10 J = 1,N M = NP1 - J VT = XR*VR - XI*VI + DBLE(C(M)) VI = XR*VI + XI*VR VR = VT 10 CONTINUE B = AMAX1(RAT,CPABS(SNGL(VR),SNGL(VI))/P) C C SAVE PRODUCT OF DISTANCES TEMPORARILY C RELERR(L) = B ABSERR(L) = B ** POWER 20 CONTINUE C 30 SHRUNK = .FALSE. DO 50 J = 1,N IF (ABSERR(J) .EQ. 0.0) GO TO 50 P = 1.0 M = N DO 40 K = 1,N IF (K .EQ. J) GO TO 40 Z = W(J) - W(K) DIST = CPABS(REAL(Z),AIMAG(Z)) CERT = DIST - ABSERR(K) IF (CERT .LT. ABSERR(J)) GO TO 40 P = P*CERT M = M - 1 40 CONTINUE OLDERR = ABSERR(J) ABSERR(J) = RELERR(J)/P IF (M .GT. 1) ABSERR(J) = ABSERR(J)**(1.0/FLOAT(M)) IF (ABSERR(J) .LT. OLDERR*0.99) SHRUNK = .TRUE. 50 CONTINUE IF (SHRUNK) GO TO 30 C DO 80 J = 1,N KLUST(J) = 1 WRAD = ABSERR(J) WNRM = CPABS(REAL(W(J)),AIMAG(W(J))) IF (WRAD .NE. 0.0) GO TO 60 R = 0.0 GO TO 80 60 IF (WNRM .NE. 0.0) GO TO 70 R = -1.0 GO TO 80 70 R = WRAD/WNRM 80 RELERR(J) = R C NM1 = N - 1 DO 100 J = 1,NM1 JP1 = J + 1 DO 90 K = JP1,N Z = W(J) - W(K) DIST = CPABS(REAL(Z),AIMAG(Z)) IF (DIST .GT. (ABSERR(J) + ABSERR(K))) GO TO 90 KLUST(J) = KLUST(J) + 1 KLUST(K) = KLUST(K) + 1 90 CONTINUE 100 CONTINUE KER = 0 RETURN C C ERROR RETURN C 200 KER = 1 RETURN 210 KER = 2 RETURN END SUBROUTINE CBND (N, C, W, ABSERR, RELERR, KLUST, KER) C----------------------------------------------------------------------- C C ABSTRACT C C THIS ROUTINE COMPUTES ERROR BOUNDS AND CLUSTER COUNTS FOR C APPROXIMATE ZEROS OF A POLYNOMIAL WITH COMPLEX COEFFICIENTS. C THE ZEROS MAY HAVE BEEN COMPUTED BY ANY APPROPRIATE ROUTINE. C THE METHOD USED IS BASED ON THE FACT THAT THE VALUE OF A C POLYNOMIAL AT ANY POINT IS EQUAL TO THE LEADING COEFFICIENT C TIMES THE PRODUCT OF THE DISTANCES FROM THAT POINT TO EACH C OF THE ZEROS. GIVEN THE VALUE OF THE POLYNOMIAL AT AN C APPROXIMATE ZERO, CBND COMPUTES FOR EACH APPROXIMATE ZERO C THE RADIUS OF A CIRCLE ABOUT THAT APPROXIMATE ZERO WHICH C CONTAINS A TRUE ZERO OF THE POLYNOMIAL. USING THE KNOWN C DISTRIBUTION OF APPROXIMATE ZEROS, AN ITERATIVE PROCEDURE C IS USED TO SHRINK THE RADII OF THE CIRCLES. C C DESCRIPTION OF ARGUMENTS C C INPUT--- C C N - DEGREE OF THE POLYNOMIAL (NUMBER OF ZEROS). C C - COMPLEX ARRAY OF N+1 COEFFICIENTS OF THE POLYNOMIAL C C(1) + C(2)*Z + ... + C(N+1)*Z**N C W - COMPLEX ARRAY OF N APPROXIMATE ZEROS. C C OUTPUT-- C C ABSERR - REAL ARRAY OF ABSOLUTE ERROR BOUNDS. ABSERR(I) IS C THE ABSOLUTE ERROR BOUND IN THE ZERO (WR(I),WI(I)). C RELERR - REAL ARRAY OF RELATIVE ERROR BOUNDS. RELERR(I) IS C THE RELATIVE ERROR BOUND IN THE ZERO (WR(I),WI(I)). C KLUST - INTEGER ARRAY OF CLUSTER COUNTS FOR ZEROS. THE TRUE C ZERO CORRESPONDING TO I-TH APPROXIMATE ZERO LIES IN C A CIRCLE OF RADIUS ABSERR(I). KLUST(I) IS THE NUMBER C OF CIRCLES INCLUDING THE I-TH CIRCLE WHICH OVERLAP C THE I-TH CIRCLE. THE CLUSTER COUNT OFTEN INDICATES C THE MULTIPLICITY OF A ZERO. C KER - AN ERROR CODE C --NORMAL CODES C 0 MEANS THE BOUNDS AND COUNTS WERE COMPUTED. C --ABNORMAL CODES C 1 N (DEGREE) MUST BE .GE. 1 C 2 LEADING COEFFICIENT IS ZERO C C------------------- C WRITTEN BY CARL B. BAILEY AND MODIFIED BY WILLIAM R. GAVIN C SANDIA LABORATORIES C ALBUQUERQUE, NEW MEXICO C JANUARY 1976 C MODIFIED BY A.H. MORRIS (NSWC) C----------------------------------------------------------------------- COMPLEX C(*), W(N), Z INTEGER KLUST(N) REAL ABSERR(N), RELERR(N) DOUBLE PRECISION XR, XI, VR, VI, VT LOGICAL SHRUNK C----------------------------------------------------------------------- C C ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE C SMALLEST NUMBER SUCH THAT 1 + EPS .GT. 1. C EPS = SPMPAR(1) C C----------------------------------------------------------------------- IF (N .LT. 1) GO TO 200 NP1 = N + 1 POWER = 1.0/FLOAT(N) P = CPABS(REAL(C(NP1)),AIMAG(C(NP1))) IF (P .EQ. 0.0) GO TO 210 RAT = 4.0*EPS*CPABS(REAL(C(1)),AIMAG(C(1)))/P C DO 20 L = 1,N XR = REAL(W(L)) XI = AIMAG(W(L)) VR = REAL(C(NP1)) VI = AIMAG(C(NP1)) DO 10 J = 1,N M = NP1 - J VT = XR*VR - XI*VI + DBLE(REAL(C(M))) VI = XR*VI + XI*VR + DBLE(AIMAG(C(M))) VR = VT 10 CONTINUE B = AMAX1(RAT,CPABS(SNGL(VR),SNGL(VI))/P) C C SAVE PRODUCT OF DISTANCES TEMPORARILY C RELERR(L) = B ABSERR(L) = B ** POWER 20 CONTINUE C 30 SHRUNK = .FALSE. DO 50 J = 1,N IF (ABSERR(J) .EQ. 0.0) GO TO 50 P = 1.0 M = N DO 40 K = 1,N IF (K .EQ. J) GO TO 40 Z = W(J) - W(K) DIST = CPABS(REAL(Z),AIMAG(Z)) CERT = DIST - ABSERR(K) IF (CERT .LT. ABSERR(J)) GO TO 40 P = P*CERT M = M - 1 40 CONTINUE OLDERR = ABSERR(J) ABSERR(J) = RELERR(J)/P IF (M .GT. 1) ABSERR(J) = ABSERR(J)**(1.0/FLOAT(M)) IF (ABSERR(J) .LT. OLDERR*0.99) SHRUNK = .TRUE. 50 CONTINUE IF (SHRUNK) GO TO 30 C DO 80 J = 1,N KLUST(J) = 1 WRAD = ABSERR(J) WNRM = CPABS(REAL(W(J)),AIMAG(W(J))) IF (WRAD .NE. 0.0) GO TO 60 R = 0.0 GO TO 80 60 IF (WNRM .NE. 0.0) GO TO 70 R = -1.0 GO TO 80 70 R = WRAD/WNRM 80 RELERR(J) = R C NM1 = N - 1 DO 100 J = 1,NM1 JP1 = J + 1 DO 90 K = JP1,N Z = W(J) - W(K) DIST = CPABS(REAL(Z),AIMAG(Z)) IF (DIST .GT. (ABSERR(J) + ABSERR(K))) GO TO 90 KLUST(J) = KLUST(J) + 1 KLUST(K) = KLUST(K) + 1 90 CONTINUE 100 CONTINUE KER = 0 RETURN C C ERROR RETURN C 200 KER = 1 RETURN 210 KER = 2 RETURN END SUBROUTINE SCOPY(N,SX,INCX,SY,INCY) C C COPIES A VECTOR, X, TO A VECTOR, Y. C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO 1. C JACK DONGARRA, LINPACK, 3/11/78. C REAL SX(*),SY(*) 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 SY(IY) = SX(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 SY(I) = SX(I) 30 CONTINUE IF( N .LT. 7 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,7 SY(I) = SX(I) SY(I + 1) = SX(I + 1) SY(I + 2) = SX(I + 2) SY(I + 3) = SX(I + 3) SY(I + 4) = SX(I + 4) SY(I + 5) = SX(I + 5) SY(I + 6) = SX(I + 6) 50 CONTINUE 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 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 CCOPY(N,CX,INCX,CY,INCY) C C COPIES A VECTOR, X, TO A VECTOR, Y. C JACK DONGARRA, LINPACK, 3/11/78. C COMPLEX CX(*),CY(*) INTEGER I,INCX,INCY,IX,IY,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 CY(IY) = CX(IX) IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C 20 DO 30 I = 1,N CY(I) = CX(I) 30 CONTINUE RETURN END SUBROUTINE ISWAP (N,IX,INCX,IY,INCY) C C EXTENDED B L A S SUBPROGRAM C C DESCRIPTION OF PARAMETERS C C --INPUT-- C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) C IX INTEGER VECTOR WITH N ELEMENTS C INCX STORAGE SPACING BETWEEN ELEMENTS OF IX C IY INTEGER VECTOR WITH N ELEMENTS C INCY STORAGE SPACING BETWEEN ELEMENTS OF IY C C --OUTPUT-- C IX INPUT VECTOR IY (UNCHANGED IF N .LE. 0) C IY INPUT VECTOR IX (UNCHANGED IF N .LE. 0) C C INTERCHANGE INTEGER IX AND INTEGER IY. C FOR I = 0 TO N-1, INTERCHANGE IX(LX+I*INCX) AND IY(LY+I*INCY), C WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS C DEFINED IN A SIMILAR WAY USING INCY. C C***AUTHOR VANDEVENDER, W. (SNLA), 1985 C INTEGER IX(*),IY(*),ITEMP1,ITEMP2,ITEMP3 C IF (N .LE. 0) RETURN IF (INCX .NE. INCY) GO TO 5 IF (INCX-1) 5,20,60 5 CONTINUE C C CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS. C IIX = 1 IIY = 1 IF (INCX .LT. 0) IIX = (1-N)*INCX + 1 IF (INCY .LT. 0) IIY = (1-N)*INCY + 1 DO 10 I = 1,N ITEMP1 = IX(IIX) IX(IIX) = IY(IIY) IY(IIY) = ITEMP1 IIX = IIX + INCX IIY = IIY + INCY 10 CONTINUE RETURN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C C C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 3. C 20 M = MOD(N,3) IF (M .EQ. 0) GO TO 40 DO 30 I = 1,M ITEMP1 = IX(I) IX(I) = IY(I) IY(I) = ITEMP1 30 CONTINUE IF (N .LT. 3) RETURN C 40 MP1 = M + 1 DO 50 I = MP1,N,3 ITEMP1 = IX(I) ITEMP2 = IX(I+1) ITEMP3 = IX(I+2) IX(I) = IY(I) IX(I+1) = IY(I+1) IX(I+2) = IY(I+2) IY(I) = ITEMP1 IY(I+1) = ITEMP2 IY(I+2) = ITEMP3 50 CONTINUE RETURN C C CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. C 60 NS = N*INCX DO 70 I = 1,NS,INCX ITEMP1 = IX(I) IX(I) = IY(I) IY(I) = ITEMP1 70 CONTINUE RETURN END SUBROUTINE SSWAP (N,SX,INCX,SY,INCY) C C INTERCHANGES TWO VECTORS. C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO 1. C JACK DONGARRA, LINPACK, 3/11/78. C REAL SX(*),SY(*),STEMP 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 STEMP = SX(IX) SX(IX) = SY(IY) SY(IY) = STEMP 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 STEMP = SX(I) SX(I) = SY(I) SY(I) = STEMP 30 CONTINUE IF( N .LT. 3 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,3 STEMP = SX(I) SX(I) = SY(I) SY(I) = STEMP STEMP = SX(I + 1) SX(I + 1) = SY(I + 1) SY(I + 1) = STEMP STEMP = SX(I + 2) SX(I + 2) = SY(I + 2) SY(I + 2) = STEMP 50 CONTINUE RETURN 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 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 CSWAP (N,CX,INCX,CY,INCY) C C INTERCHANGES TWO VECTORS. C JACK DONGARRA, LINPACK, 3/11/78. C COMPLEX CX(*),CY(*),CTEMP INTEGER I,INCX,INCY,IX,IY,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 CTEMP = CX(IX) CX(IX) = CY(IY) CY(IY) = CTEMP IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 20 DO 30 I = 1,N CTEMP = CX(I) CX(I) = CY(I) CY(I) = CTEMP 30 CONTINUE RETURN END SUBROUTINE SROT (N,SX,INCX,SY,INCY,C,S) C C APPLIES A PLANE ROTATION. C JACK DONGARRA, LINPACK, 3/11/78. C REAL SX(*),SY(*),STEMP,C,S INTEGER I,INCX,INCY,IX,IY,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 STEMP = C*SX(IX) + S*SY(IY) SY(IY) = C*SY(IY) - S*SX(IX) SX(IX) = STEMP IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C 20 DO 30 I = 1,N STEMP = C*SX(I) + S*SY(I) SY(I) = C*SY(I) - S*SX(I) SX(I) = STEMP 30 CONTINUE RETURN END SUBROUTINE DROT (N,DX,INCX,DY,INCY,C,S) C C APPLIES A PLANE ROTATION. C JACK DONGARRA, LINPACK, 3/11/78. C DOUBLE PRECISION DX(*),DY(*),DTEMP,C,S INTEGER I,INCX,INCY,IX,IY,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 = C*DX(IX) + S*DY(IY) DY(IY) = C*DY(IY) - S*DX(IX) DX(IX) = DTEMP IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C 20 DO 30 I = 1,N DTEMP = C*DX(I) + S*DY(I) DY(I) = C*DY(I) - S*DX(I) DX(I) = DTEMP 30 CONTINUE RETURN END SUBROUTINE CSROT (N,CX,INCX,CY,INCY,C,S) C C APPLIES A PLANE ROTATION, WHERE THE COS AND SIN (C AND S) ARE REAL C AND THE VECTORS CX AND CY ARE COMPLEX. C JACK DONGARRA, LINPACK, 3/11/78. C COMPLEX CX(*),CY(*),CTEMP REAL C,S INTEGER I,INCX,INCY,IX,IY,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 CTEMP = C*CX(IX) + S*CY(IY) CY(IY) = C*CY(IY) - S*CX(IX) CX(IX) = CTEMP IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C 20 DO 30 I = 1,N CTEMP = C*CX(I) + S*CY(I) CY(I) = C*CY(I) - S*CX(I) CX(I) = CTEMP 30 CONTINUE RETURN END SUBROUTINE SROTMG (SD1,SD2,SX1,SY1,SPARAM) C C CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS C THE SECOND COMPONENT OF THE 2-VECTOR (SQRT(SD1)*SX1,SQRT(SD2)* C SY1)**T. C WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS.. C C SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0 C C (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0) C H=( ) ( ) ( ) ( ) C (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0). C C LOCATIONS 2-4 OF SPARAM CONTAIN SH11,SH21,SH12, AND SH22 C RESPECTIVELY. (VALUES OF 1.E0, -1.E0, OR 0.E0 IMPLIED BY THE C VALUE OF SPARAM(1) ARE NOT STORED IN SPARAM.) C C IT IS ASSUMED THAT GAMSQ = GAM*GAM AND RGAMSQ = ONE/(GAM*GAM). C THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE C INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE C OF SD1 AND SD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. C DIMENSION SPARAM(5) C DATA ZERO,ONE,TWO /0.E0,1.E0,2.E0/ DATA GAM,GAMSQ,RGAMSQ/4096.E0,1.67772E7,5.96046E-8/ C IF (SD1 .LT. ZERO) GO TO 60 SP2 = SD2*SY1 IF (SP2 .NE. ZERO) GO TO 20 SFLAG = -TWO GO TO 260 C C REGULAR-CASE.. C 20 SP1 = SD1*SX1 SQ1 = SP1*SX1 SQ2 = SP2*SY1 C IF (ABS(SQ1) .LE. ABS(SQ2)) GO TO 40 SH21 = -SY1/SX1 SH12 = SP2/SP1 C SU = ONE - SH12*SH21 IF (SU .LE. ZERO) GO TO 60 C SFLAG = ZERO SH11 = ONE SH22 = ONE SD1 = SD1/SU SD2 = SD2/SU SX1 = SX1*SU C GO SCALE-CHECK.. GO TO 100 C 40 CONTINUE IF (SD2 .LT. ZERO) GO TO 60 SFLAG = ONE SH11 = SP1/SP2 SH21 = -ONE SH12 = ONE SH22 = SX1/SY1 C SU = ONE + SH11*SH22 STEMP = SD2/SU SD2 = SD1/SU SD1 = STEMP SX1 = SY1*SU C GO SCALE-CHECK GO TO 100 C C PROCEDURE..ZERO-H-D-AND-SX1.. C 60 CONTINUE SFLAG = -ONE SH11 = ZERO SH12 = ZERO SH21 = ZERO SH22 = ZERO C SD1 = ZERO SD2 = ZERO SX1 = ZERO GO TO 250 C C PROCEDURE..SCALE-CHECK C 100 CONTINUE 110 CONTINUE IF (SD1 .GT. RGAMSQ) GO TO 130 IF (SD1 .EQ. ZERO) GO TO 160 SFLAG = -ONE SD1 = SD1*(GAM*GAM) SX1 = SX1/GAM SH11 = SH11/GAM SH12 = SH12/GAM GO TO 110 C 130 CONTINUE 140 CONTINUE IF (SD1 .LT. GAMSQ) GO TO 160 SFLAG = -ONE SD1 = SD1/(GAM*GAM) SX1 = SX1*GAM SH11 = SH11*GAM SH12 = SH12*GAM GO TO 140 C 160 CONTINUE 170 CONTINUE IF (ABS(SD2) .GT. RGAMSQ) GO TO 190 IF (SD2 .EQ. ZERO) GO TO 220 SFLAG = -ONE SD2 = SD2*(GAM*GAM) SH21 = SH21/GAM SH22 = SH22/GAM GO TO 170 C 190 CONTINUE 200 CONTINUE IF (ABS(SD2) .LT. GAMSQ) GO TO 220 SFLAG = -ONE SD2 = SD2/(GAM*GAM) SH21 = SH21*GAM SH22 = SH22*GAM GO TO 200 C 220 CONTINUE IF(SFLAG)250,230,240 230 CONTINUE SPARAM(3)=SH21 SPARAM(4)=SH12 GO TO 260 240 CONTINUE SPARAM(2)=SH11 SPARAM(5)=SH22 GO TO 260 250 CONTINUE SPARAM(2)=SH11 SPARAM(3)=SH21 SPARAM(4)=SH12 SPARAM(5)=SH22 260 CONTINUE SPARAM(1)=SFLAG RETURN END SUBROUTINE SROTM (N,SX,INCX,SY,INCY,SPARAM) C C APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX C C (SX**T), WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF SX ARE IN C (SY**T) C C SX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE C LX = (-INCX)*N, AND SIMILARLY FOR SY USING USING LY AND INCY. C C WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS.. C C SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0 C C (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0) C H=( ) ( ) ( ) ( ) C (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0). C DIMENSION SX(*), SY(*), SPARAM(5) C DATA ZERO,TWO/0.E0,2.E0/ C SFLAG=SPARAM(1) IF(N .LE. 0 .OR.(SFLAG+TWO.EQ.ZERO)) GO TO 140 IF(.NOT.(INCX.EQ.INCY.AND. INCX .GT.0)) GO TO 70 C NSTEPS=N*INCX IF(SFLAG) 50,10,30 10 CONTINUE SH21=SPARAM(3) SH12=SPARAM(4) DO 20 I=1,NSTEPS,INCX W=SX(I) Z=SY(I) SX(I)=W+Z*SH12 SY(I)=W*SH21+Z 20 CONTINUE GO TO 140 30 CONTINUE SH11=SPARAM(2) SH22=SPARAM(5) DO 40 I=1,NSTEPS,INCX W=SX(I) Z=SY(I) SX(I)=W*SH11+Z SY(I)=-W+SH22*Z 40 CONTINUE GO TO 140 50 CONTINUE SH11=SPARAM(2) SH21=SPARAM(3) SH12=SPARAM(4) SH22=SPARAM(5) DO 60 I=1,NSTEPS,INCX W=SX(I) Z=SY(I) SX(I)=W*SH11+Z*SH12 SY(I)=W*SH21+Z*SH22 60 CONTINUE GO TO 140 70 CONTINUE KX=1 KY=1 IF(INCX .LT. 0) KX=1+(1-N)*INCX IF(INCY .LT. 0) KY=1+(1-N)*INCY C IF(SFLAG)120,80,100 80 CONTINUE SH21=SPARAM(3) SH12=SPARAM(4) DO 90 I=1,N W=SX(KX) Z=SY(KY) SX(KX)=W+Z*SH12 SY(KY)=W*SH21+Z KX=KX+INCX KY=KY+INCY 90 CONTINUE GO TO 140 100 CONTINUE SH11=SPARAM(2) SH22=SPARAM(5) DO 110 I=1,N W=SX(KX) Z=SY(KY) SX(KX)=W*SH11+Z SY(KY)=-W+SH22*Z KX=KX+INCX KY=KY+INCY 110 CONTINUE GO TO 140 120 CONTINUE SH11=SPARAM(2) SH21=SPARAM(3) SH12=SPARAM(4) SH22=SPARAM(5) DO 130 I=1,N W=SX(KX) Z=SY(KY) SX(KX)=W*SH11+Z*SH12 SY(KY)=W*SH21+Z*SH22 KX=KX+INCX KY=KY+INCY 130 CONTINUE 140 CONTINUE RETURN END SUBROUTINE DROTMG (DD1,DD2,DX1,DY1,DPARAM) C C CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS C THE SECOND COMPONENT OF THE 2-VECTOR (DSQRT(DD1)*DX1,DSQRT(DD2)* C DY1)**T. C WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. C C DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 C C (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) C H=( ) ( ) ( ) ( ) C (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). C C LOCATIONS 2-4 OF DPARAM CONTAIN DH11,DH21,DH12, AND DH22 C RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE C VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.) C C IT IS ASSUMED THAT GAMSQ = GAM*GAM AND RGAMSQ = ONE/(GAM*GAM). C THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE C INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE C OF DD1 AND DD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. C DOUBLE PRECISION GAM,ONE,RGAMSQ,DD2,DH11,DH21,DPARAM,DP2, 1 DQ2,DU,DY1,ZERO,GAMSQ,DD1,DFLAG,DH12,DH22,DP1,DQ1, 2 DTEMP,DX1,TWO DIMENSION DPARAM(5) C DATA ZERO,ONE,TWO /0.D0,1.D0,2.D0/ DATA GAM,GAMSQ,RGAMSQ/4096.D0,16777216.D0,5.9604645D-8/ C IF (DD1 .LT. ZERO) GO TO 60 DP2 = DD2*DY1 IF (DP2 .NE. ZERO) GO TO 20 DFLAG = -TWO GO TO 260 C C REGULAR-CASE.. C 20 DP1 = DD1*DX1 DQ1 = DP1*DX1 DQ2 = DP2*DY1 C IF (DABS(DQ1) .LE. DABS(DQ2)) GO TO 40 DH21 = -DY1/DX1 DH12 = DP2/DP1 C DU = ONE - DH12*DH21 IF (DU .LE. ZERO) GO TO 60 C DFLAG = ZERO DH11 = ONE DH22 = ONE DD1 = DD1/DU DD2 = DD2/DU DX1 = DX1*DU C GO SCALE-CHECK.. GO TO 100 C 40 CONTINUE IF (DD2 .LT. ZERO) GO TO 60 DFLAG = ONE DH11 = DP1/DP2 DH21 = -ONE DH12 = ONE DH22 = DX1/DY1 C DU = ONE + DH11*DH22 DTEMP = DD2/DU DD2 = DD1/DU DD1 = DTEMP DX1 = DY1*DU C GO SCALE-CHECK GO TO 100 C C PROCEDURE..ZERO-H-D-AND-DX1.. C 60 CONTINUE DFLAG = -ONE DH11 = ZERO DH12 = ZERO DH21 = ZERO DH22 = ZERO C DD1 = ZERO DD2 = ZERO DX1 = ZERO GO TO 250 C C PROCEDURE..SCALE-CHECK C 100 CONTINUE 110 CONTINUE IF (DD1 .GT. RGAMSQ) GO TO 130 IF (DD1 .EQ. ZERO) GO TO 160 DFLAG = -ONE DD1 = DD1*(GAM*GAM) DX1 = DX1/GAM DH11 = DH11/GAM DH12 = DH12/GAM GO TO 110 C 130 CONTINUE 140 CONTINUE IF (DD1 .LT. GAMSQ) GO TO 160 DFLAG = -ONE DD1 = DD1/(GAM*GAM) DX1 = DX1*GAM DH11 = DH11*GAM DH12 = DH12*GAM GO TO 140 C 160 CONTINUE 170 CONTINUE IF (DABS(DD2) .GT. RGAMSQ) GO TO 190 IF (DD2 .EQ. ZERO) GO TO 220 DFLAG = -ONE DD2 = DD2*(GAM*GAM) DH21 = DH21/GAM DH22 = DH22/GAM GO TO 170 C 190 CONTINUE 200 CONTINUE IF (DABS(DD2) .LT. GAMSQ) GO TO 220 DFLAG = -ONE DD2 = DD2/(GAM*GAM) DH21 = DH21*GAM DH22 = DH22*GAM GO TO 200 C 220 CONTINUE IF(DFLAG)250,230,240 230 CONTINUE DPARAM(3)=DH21 DPARAM(4)=DH12 GO TO 260 240 CONTINUE DPARAM(2)=DH11 DPARAM(5)=DH22 GO TO 260 250 CONTINUE DPARAM(2)=DH11 DPARAM(3)=DH21 DPARAM(4)=DH12 DPARAM(5)=DH22 260 CONTINUE DPARAM(1)=DFLAG RETURN END SUBROUTINE DROTM (N,DX,INCX,DY,INCY,DPARAM) C C APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX C C (DX**T), WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF DX ARE IN C (DY**T) C C DX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE C LX = (-INCX)*N, AND SIMILARLY FOR SY USING LY AND INCY. C C WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. C C DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 C C (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) C H=( ) ( ) ( ) ( ) C (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). C DOUBLE PRECISION DFLAG,DH12,DH22,DX,TWO,Z,DH11,DH21, * DPARAM,DY,W,ZERO DIMENSION DX(*), DY(*), DPARAM(5) C DATA ZERO,TWO/0.D0,2.D0/ C DFLAG=DPARAM(1) IF(N .LE. 0 .OR.(DFLAG+TWO.EQ.ZERO)) GO TO 140 IF(.NOT.(INCX.EQ.INCY.AND. INCX .GT.0)) GO TO 70 C NSTEPS=N*INCX IF(DFLAG) 50,10,30 10 CONTINUE DH21=DPARAM(3) DH12=DPARAM(4) DO 20 I=1,NSTEPS,INCX W=DX(I) Z=DY(I) DX(I)=W+Z*DH12 DY(I)=W*DH21+Z 20 CONTINUE GO TO 140 30 CONTINUE DH11=DPARAM(2) DH22=DPARAM(5) DO 40 I=1,NSTEPS,INCX W=DX(I) Z=DY(I) DX(I)=W*DH11+Z DY(I)=-W+DH22*Z 40 CONTINUE GO TO 140 50 CONTINUE DH11=DPARAM(2) DH21=DPARAM(3) DH12=DPARAM(4) DH22=DPARAM(5) DO 60 I=1,NSTEPS,INCX W=DX(I) Z=DY(I) DX(I)=W*DH11+Z*DH12 DY(I)=W*DH21+Z*DH22 60 CONTINUE GO TO 140 70 CONTINUE KX=1 KY=1 IF(INCX .LT. 0) KX=1+(1-N)*INCX IF(INCY .LT. 0) KY=1+(1-N)*INCY C IF(DFLAG)120,80,100 80 CONTINUE DH21=DPARAM(3) DH12=DPARAM(4) DO 90 I=1,N W=DX(KX) Z=DY(KY) DX(KX)=W+Z*DH12 DY(KY)=W*DH21+Z KX=KX+INCX KY=KY+INCY 90 CONTINUE GO TO 140 100 CONTINUE DH11=DPARAM(2) DH22=DPARAM(5) DO 110 I=1,N W=DX(KX) Z=DY(KY) DX(KX)=W*DH11+Z DY(KY)=-W+DH22*Z KX=KX+INCX KY=KY+INCY 110 CONTINUE GO TO 140 120 CONTINUE DH11=DPARAM(2) DH21=DPARAM(3) DH12=DPARAM(4) DH22=DPARAM(5) DO 130 I=1,N W=DX(KX) Z=DY(KY) DX(KX)=W*DH11+Z*DH12 DY(KY)=W*DH21+Z*DH22 KX=KX+INCX KY=KY+INCY 130 CONTINUE 140 CONTINUE RETURN END REAL FUNCTION SDOT(N,SX,INCX,SY,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 REAL SX(*),SY(*),STEMP INTEGER I,INCX,INCY,IX,IY,M,MP1,N C STEMP = 0.0E0 SDOT = 0.0E0 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 STEMP = STEMP + SX(IX)*SY(IY) IX = IX + INCX IY = IY + INCY 10 CONTINUE SDOT = STEMP 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 STEMP = STEMP + SX(I)*SY(I) 30 CONTINUE IF( N .LT. 5 ) GO TO 60 40 MP1 = M + 1 DO 50 I = MP1,N,5 STEMP = STEMP + SX(I)*SY(I) + SX(I + 1)*SY(I + 1) + * SX(I + 2)*SY(I + 2) + SX(I + 3)*SY(I + 3) + SX(I + 4)*SY(I + 4) 50 CONTINUE 60 SDOT = STEMP 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 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 COMPLEX FUNCTION CDOTC(N,CX,INCX,CY,INCY) C C FORMS THE DOT PRODUCT OF TWO VECTORS, CONJUGATING THE FIRST C VECTOR. C JACK DONGARRA, LINPACK, 3/11/78. C COMPLEX CX(*),CY(*),CTEMP INTEGER I,INCX,INCY,IX,IY,N C CTEMP = (0.0,0.0) CDOTC = (0.0,0.0) 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 CTEMP = CTEMP + CONJG(CX(IX))*CY(IY) IX = IX + INCX IY = IY + INCY 10 CONTINUE CDOTC = CTEMP RETURN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C 20 DO 30 I = 1,N CTEMP = CTEMP + CONJG(CX(I))*CY(I) 30 CONTINUE CDOTC = CTEMP RETURN END COMPLEX FUNCTION CDOTU(N,CX,INCX,CY,INCY) C C FORMS THE DOT PRODUCT OF TWO VECTORS. C JACK DONGARRA, LINPACK, 3/11/78. C COMPLEX CX(*),CY(*),CTEMP INTEGER I,INCX,INCY,IX,IY,N C CTEMP = (0.0,0.0) CDOTU = (0.0,0.0) 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 CTEMP = CTEMP + CX(IX)*CY(IY) IX = IX + INCX IY = IY + INCY 10 CONTINUE CDOTU = CTEMP RETURN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C 20 DO 30 I = 1,N CTEMP = CTEMP + CX(I)*CY(I) 30 CONTINUE CDOTU = CTEMP RETURN END SUBROUTINE SSCAL(N,SA,SX,INCX) C C SCALES A VECTOR BY A CONSTANT. C USES UNROLLED LOOPS FOR INCREMENT EQUAL TO 1. C JACK DONGARRA, LINPACK, 3/11/78. C REAL SA,SX(*) INTEGER I,INCX,M,MP1,N,NINCX C IF(N.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 SX(I) = SA*SX(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 SX(I) = SA*SX(I) 30 CONTINUE IF( N .LT. 5 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,5 SX(I) = SA*SX(I) SX(I + 1) = SA*SX(I + 1) SX(I + 2) = SA*SX(I + 2) SX(I + 3) = SA*SX(I + 3) SX(I + 4) = SA*SX(I + 4) 50 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 DOUBLE PRECISION DA,DX(*) INTEGER I,INCX,M,MP1,N,NINCX C IF(N.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 CSCAL(N,CA,CX,INCX) C C SCALES A VECTOR BY A CONSTANT. C JACK DONGARRA, LINPACK, 3/11/78. C COMPLEX CA,CX(*) INTEGER I,INCX,N,NINCX C IF(N.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 CX(I) = CA*CX(I) 10 CONTINUE RETURN C C CODE FOR INCREMENT EQUAL TO 1 C 20 DO 30 I = 1,N CX(I) = CA*CX(I) 30 CONTINUE RETURN END SUBROUTINE CSSCAL(N,SA,CX,INCX) C C SCALES A COMPLEX VECTOR BY A REAL CONSTANT. C JACK DONGARRA, LINPACK, 3/11/78. C COMPLEX CX(*) REAL SA INTEGER I,INCX,N,NINCX C IF(N.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 CX(I) = CMPLX(SA*REAL(CX(I)),SA*AIMAG(CX(I))) 10 CONTINUE RETURN C C CODE FOR INCREMENT EQUAL TO 1 C 20 DO 30 I = 1,N CX(I) = CMPLX(SA*REAL(CX(I)),SA*AIMAG(CX(I))) 30 CONTINUE RETURN END SUBROUTINE SAXPY(N,SA,SX,INCX,SY,INCY) C C CONSTANT TIMES A VECTOR PLUS A VECTOR. C USES UNROLLED LOOP FOR INCREMENTS EQUAL TO ONE. C JACK DONGARRA, LINPACK, 3/11/78. C REAL SX(*),SY(*),SA INTEGER I,INCX,INCY,IX,IY,M,MP1,N C IF(N.LE.0)RETURN IF (SA .EQ. 0.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 SY(IY) = SY(IY) + SA*SX(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 SY(I) = SY(I) + SA*SX(I) 30 CONTINUE IF( N .LT. 4 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,4 SY(I) = SY(I) + SA*SX(I) SY(I + 1) = SY(I + 1) + SA*SX(I + 1) SY(I + 2) = SY(I + 2) + SA*SX(I + 2) SY(I + 3) = SY(I + 3) + SA*SX(I + 3) 50 CONTINUE RETURN 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 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 SUBROUTINE CAXPY(N,CA,CX,INCX,CY,INCY) C C CONSTANT TIMES A VECTOR PLUS A VECTOR. C JACK DONGARRA, LINPACK, 3/11/78. C COMPLEX CX(*),CY(*),CA INTEGER I,INCX,INCY,IX,IY,N C IF(N.LE.0)RETURN IF (ABS(REAL(CA)) + ABS(AIMAG(CA)) .EQ. 0.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 CY(IY) = CY(IY) + CA*CX(IX) IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C 20 DO 30 I = 1,N CY(I) = CY(I) + CA*CX(I) 30 CONTINUE RETURN END REAL FUNCTION SASUM(N,SX,INCX) C C TAKES THE SUM OF THE ABSOLUTE VALUES. C USES UNROLLED LOOPS FOR INCREMENT EQUAL TO ONE. C JACK DONGARRA, LINPACK, 3/11/78. C REAL SX(*),STEMP INTEGER I,INCX,M,MP1,N,NINCX C SASUM = 0.0E0 STEMP = 0.0E0 IF(N.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 STEMP = STEMP + ABS(SX(I)) 10 CONTINUE SASUM = STEMP 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 STEMP = STEMP + ABS(SX(I)) 30 CONTINUE IF( N .LT. 6 ) GO TO 60 40 MP1 = M + 1 DO 50 I = MP1,N,6 STEMP = STEMP + ABS(SX(I)) + ABS(SX(I + 1)) + ABS(SX(I + 2)) * + ABS(SX(I + 3)) + ABS(SX(I + 4)) + ABS(SX(I + 5)) 50 CONTINUE 60 SASUM = STEMP RETURN 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 DOUBLE PRECISION DX(*),DTEMP INTEGER I,INCX,M,MP1,N,NINCX C DASUM = 0.0D0 DTEMP = 0.0D0 IF(N.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 REAL FUNCTION SCASUM(N,CX,INCX) C C TAKES THE SUM OF THE ABSOLUTE VALUES OF A COMPLEX VECTOR AND C RETURNS A SINGLE PRECISION RESULT. C JACK DONGARRA, LINPACK, 3/11/78. C COMPLEX CX(*) REAL STEMP INTEGER I,INCX,N,NINCX C SCASUM = 0.0E0 STEMP = 0.0E0 IF(N.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 STEMP = STEMP + ABS(REAL(CX(I))) + ABS(AIMAG(CX(I))) 10 CONTINUE SCASUM = STEMP RETURN C C CODE FOR INCREMENT EQUAL TO 1 C 20 DO 30 I = 1,N STEMP = STEMP + ABS(REAL(CX(I))) + ABS(AIMAG(CX(I))) 30 CONTINUE SCASUM = STEMP RETURN END REAL FUNCTION SNRM2 ( N, SX, INCX) INTEGER NEXT REAL SX(*), CUTLO, CUTHI, HITEST, SUM, XMAX, ZERO, ONE DATA ZERO, ONE /0.0E0, 1.0E0/ C C EUCLIDEAN NORM OF THE N-VECTOR STORED IN SX() WITH STORAGE C INCREMENT INCX . C IF N .LE. 0 RETURN WITH RESULT = 0. C IF N .GE. 1 THEN INCX MUST BE .GE. 1 C C C.L.LAWSON, 1978 JAN 08 C C FOUR PHASE METHOD USING TWO BUILT-IN CONSTANTS THAT ARE C HOPEFULLY APPLICABLE TO ALL MACHINES. C CUTLO = MAXIMUM OF SQRT(U/EPS) OVER ALL KNOWN MACHINES. C CUTHI = MINIMUM OF SQRT(V) OVER ALL KNOWN MACHINES. C WHERE C EPS = SMALLEST NO. SUCH THAT EPS + 1. .GT. 1. C U = SMALLEST POSITIVE NO. (UNDERFLOW LIMIT) C V = LARGEST NO. (OVERFLOW LIMIT) C C BRIEF OUTLINE OF ALGORITHM.. C C PHASE 1 SCANS ZERO COMPONENTS. C MOVE TO PHASE 2 WHEN A COMPONENT IS NONZERO AND .LE. CUTLO C MOVE TO PHASE 3 WHEN A COMPONENT IS .GT. CUTLO C MOVE TO PHASE 4 WHEN A COMPONENT IS .GE. CUTHI/M C WHERE M = N FOR X() REAL AND M = 2*N FOR COMPLEX. C C VALUES FOR CUTLO AND CUTHI.. C FROM THE ENVIRONMENTAL PARAMETERS LISTED IN THE IMSL CONVERTER C DOCUMENT THE LIMITING VALUES ARE AS FOLLOWS.. C CUTLO, S.P. U/EPS = 2**(-102) FOR HONEYWELL. CLOSE SECONDS ARE C UNIVAC AND DEC AT 2**(-103) C THUS CUTLO = 2**(-51) = 4.44089E-16 C CUTHI, S.P. V = 2**127 FOR UNIVAC, HONEYWELL, AND DEC. C THUS CUTHI = 2**(63.5) = 1.30438E19 C CUTLO, D.P. U/EPS = 2**(-67) FOR HONEYWELL AND DEC. C THUS CUTLO = 2**(-33.5) = 8.23181D-11 C CUTHI, D.P. SAME AS S.P. CUTHI = 1.30438D19 C DATA CUTLO, CUTHI / 8.232D-11, 1.304D19 / C DATA CUTLO, CUTHI / 4.441E-16, 1.304E19 / DATA CUTLO, CUTHI / 4.441E-16, 1.304E19 / C IF(N .GT. 0) GO TO 10 SNRM2 = ZERO GO TO 300 C 10 ASSIGN 30 TO NEXT SUM = ZERO NN = N * INCX C BEGIN MAIN LOOP I = 1 20 GO TO NEXT,(30, 50, 70, 110) 30 IF( ABS(SX(I)) .GT. CUTLO) GO TO 85 ASSIGN 50 TO NEXT XMAX = ZERO C C PHASE 1. SUM IS ZERO C 50 IF( SX(I) .EQ. ZERO) GO TO 200 IF( ABS(SX(I)) .GT. CUTLO) GO TO 85 C C PREPARE FOR PHASE 2. ASSIGN 70 TO NEXT GO TO 105 C C PREPARE FOR PHASE 4. C 100 I = J ASSIGN 110 TO NEXT SUM = (SUM / SX(I)) / SX(I) 105 XMAX = ABS(SX(I)) GO TO 115 C C PHASE 2. SUM IS SMALL. C SCALE TO AVOID DESTRUCTIVE UNDERFLOW. C 70 IF( ABS(SX(I)) .GT. CUTLO ) GO TO 75 C C COMMON CODE FOR PHASES 2 AND 4. C IN PHASE 4 SUM IS LARGE. SCALE TO AVOID OVERFLOW. C 110 IF( ABS(SX(I)) .LE. XMAX ) GO TO 115 SUM = ONE + SUM * (XMAX / SX(I))**2 XMAX = ABS(SX(I)) GO TO 200 C 115 SUM = SUM + (SX(I)/XMAX)**2 GO TO 200 C C C PREPARE FOR PHASE 3. C 75 SUM = (SUM * XMAX) * XMAX C C C FOR REAL OR D.P. SET HITEST = CUTHI/N C FOR COMPLEX SET HITEST = CUTHI/(2*N) C 85 HITEST = CUTHI/FLOAT( N ) C C PHASE 3. SUM IS MID-RANGE. NO SCALING. C DO 95 J =I,NN,INCX IF(ABS(SX(J)) .GE. HITEST) GO TO 100 95 SUM = SUM + SX(J)**2 SNRM2 = SQRT( SUM ) GO TO 300 C 200 CONTINUE I = I + INCX IF ( I .LE. NN ) GO TO 20 C C END OF MAIN LOOP. C C COMPUTE SQUARE ROOT AND ADJUST FOR SCALING. C SNRM2 = XMAX * SQRT(SUM) 300 CONTINUE RETURN END DOUBLE PRECISION FUNCTION DNRM2 ( N, DX, INCX) INTEGER NEXT DOUBLE PRECISION DX(*), CUTLO, CUTHI, HITEST, SUM, XMAX,ZERO,ONE DATA ZERO, ONE /0.0D0, 1.0D0/ C C EUCLIDEAN NORM OF THE N-VECTOR STORED IN DX() WITH STORAGE C INCREMENT INCX . C IF N .LE. 0 RETURN WITH RESULT = 0. C IF N .GE. 1 THEN INCX MUST BE .GE. 1 C C C.L.LAWSON, 1978 JAN 08 C C FOUR PHASE METHOD USING TWO BUILT-IN CONSTANTS THAT ARE C HOPEFULLY APPLICABLE TO ALL MACHINES. C CUTLO = MAXIMUM OF DSQRT(U/EPS) OVER ALL KNOWN MACHINES. C CUTHI = MINIMUM OF DSQRT(V) OVER ALL KNOWN MACHINES. C WHERE C EPS = SMALLEST NO. SUCH THAT EPS + 1. .GT. 1. C U = SMALLEST POSITIVE NO. (UNDERFLOW LIMIT) C V = LARGEST NO. (OVERFLOW LIMIT) C C BRIEF OUTLINE OF ALGORITHM.. C C PHASE 1 SCANS ZERO COMPONENTS. C MOVE TO PHASE 2 WHEN A COMPONENT IS NONZERO AND .LE. CUTLO C MOVE TO PHASE 3 WHEN A COMPONENT IS .GT. CUTLO C MOVE TO PHASE 4 WHEN A COMPONENT IS .GE. CUTHI/M C WHERE M = N FOR X() REAL AND M = 2*N FOR COMPLEX. C C VALUES FOR CUTLO AND CUTHI.. C FROM THE ENVIRONMENTAL PARAMETERS LISTED IN THE IMSL CONVERTER C DOCUMENT THE LIMITING VALUES ARE AS FOLLOWS.. C CUTLO, S.P. U/EPS = 2**(-102) FOR HONEYWELL. CLOSE SECONDS ARE C UNIVAC AND DEC AT 2**(-103) C THUS CUTLO = 2**(-51) = 4.44089E-16 C CUTHI, S.P. V = 2**127 FOR UNIVAC, HONEYWELL, AND DEC. C THUS CUTHI = 2**(63.5) = 1.30438E19 C CUTLO, D.P. U/EPS = 2**(-67) FOR HONEYWELL AND DEC. C THUS CUTLO = 2**(-33.5) = 8.23181D-11 C CUTHI, D.P. SAME AS S.P. CUTHI = 1.30438D19 C DATA CUTLO, CUTHI / 8.232D-11, 1.304D19 / C DATA CUTLO, CUTHI / 4.441E-16, 1.304E19 / DATA CUTLO, CUTHI / 8.232D-11, 1.304D19 / C IF(N .GT. 0) GO TO 10 DNRM2 = ZERO GO TO 300 C 10 ASSIGN 30 TO NEXT SUM = ZERO NN = N * INCX C BEGIN MAIN LOOP I = 1 20 GO TO NEXT,(30, 50, 70, 110) 30 IF( DABS(DX(I)) .GT. CUTLO) GO TO 85 ASSIGN 50 TO NEXT XMAX = ZERO C C PHASE 1. SUM IS ZERO C 50 IF( DX(I) .EQ. ZERO) GO TO 200 IF( DABS(DX(I)) .GT. CUTLO) GO TO 85 C C PREPARE FOR PHASE 2. ASSIGN 70 TO NEXT GO TO 105 C C PREPARE FOR PHASE 4. C 100 I = J ASSIGN 110 TO NEXT SUM = (SUM / DX(I)) / DX(I) 105 XMAX = DABS(DX(I)) GO TO 115 C C PHASE 2. SUM IS SMALL. C SCALE TO AVOID DESTRUCTIVE UNDERFLOW. C 70 IF( DABS(DX(I)) .GT. CUTLO ) GO TO 75 C C COMMON CODE FOR PHASES 2 AND 4. C IN PHASE 4 SUM IS LARGE. SCALE TO AVOID OVERFLOW. C 110 IF( DABS(DX(I)) .LE. XMAX ) GO TO 115 SUM = ONE + SUM * (XMAX / DX(I))**2 XMAX = DABS(DX(I)) GO TO 200 C 115 SUM = SUM + (DX(I)/XMAX)**2 GO TO 200 C C C PREPARE FOR PHASE 3. C 75 SUM = (SUM * XMAX) * XMAX C C C FOR REAL OR D.P. SET HITEST = CUTHI/N C FOR COMPLEX SET HITEST = CUTHI/(2*N) C 85 HITEST = CUTHI/FLOAT( N ) C C PHASE 3. SUM IS MID-RANGE. NO SCALING. C DO 95 J =I,NN,INCX IF(DABS(DX(J)) .GE. HITEST) GO TO 100 95 SUM = SUM + DX(J)**2 DNRM2 = DSQRT( SUM ) GO TO 300 C 200 CONTINUE I = I + INCX IF ( I .LE. NN ) GO TO 20 C C END OF MAIN LOOP. C C COMPUTE SQUARE ROOT AND ADJUST FOR SCALING. C DNRM2 = XMAX * DSQRT(SUM) 300 CONTINUE RETURN END REAL FUNCTION SCNRM2( N, CX, INCX) LOGICAL IMAG, SCALE INTEGER NEXT REAL CUTLO, CUTHI, HITEST, SUM, XMAX, ABSX, ZERO, ONE COMPLEX CX(*) DATA ZERO, ONE /0.0E0, 1.0E0/ C C UNITARY NORM OF THE COMPLEX N-VECTOR STORED IN CX() WITH STORAGE C INCREMENT INCX . C IF N .LE. 0 RETURN WITH RESULT = 0. C IF N .GE. 1 THEN INCX MUST BE .GE. 1 C C C.L.LAWSON , 1978 JAN 08 C C FOUR PHASE METHOD USING TWO BUILT-IN CONSTANTS THAT ARE C HOPEFULLY APPLICABLE TO ALL MACHINES. C CUTLO = MAXIMUM OF SQRT(U/EPS) OVER ALL KNOWN MACHINES. C CUTHI = MINIMUM OF SQRT(V) OVER ALL KNOWN MACHINES. C WHERE C EPS = SMALLEST NO. SUCH THAT EPS + 1. .GT. 1. C U = SMALLEST POSITIVE NO. (UNDERFLOW LIMIT) C V = LARGEST NO. (OVERFLOW LIMIT) C C BRIEF OUTLINE OF ALGORITHM.. C C PHASE 1 SCANS ZERO COMPONENTS. C MOVE TO PHASE 2 WHEN A COMPONENT IS NONZERO AND .LE. CUTLO C MOVE TO PHASE 3 WHEN A COMPONENT IS .GT. CUTLO C MOVE TO PHASE 4 WHEN A COMPONENT IS .GE. CUTHI/M C WHERE M = N FOR X() REAL AND M = 2*N FOR COMPLEX. C C VALUES FOR CUTLO AND CUTHI.. C FROM THE ENVIRONMENTAL PARAMETERS LISTED IN THE IMSL CONVERTER C DOCUMENT THE LIMITING VALUES ARE AS FOLLOWS.. C CUTLO, S.P. U/EPS = 2**(-102) FOR HONEYWELL. CLOSE SECONDS ARE C UNIVAC AND DEC AT 2**(-103) C THUS CUTLO = 2**(-51) = 4.44089E-16 C CUTHI, S.P. V = 2**127 FOR UNIVAC, HONEYWELL, AND DEC. C THUS CUTHI = 2**(63.5) = 1.30438E19 C CUTLO, D.P. U/EPS = 2**(-67) FOR HONEYWELL AND DEC. C THUS CUTLO = 2**(-33.5) = 8.23181D-11 C CUTHI, D.P. SAME AS S.P. CUTHI = 1.30438D19 C DATA CUTLO, CUTHI / 8.232D-11, 1.304D19 / C DATA CUTLO, CUTHI / 4.441E-16, 1.304E19 / DATA CUTLO, CUTHI / 4.441E-16, 1.304E19 / C IF(N .GT. 0) GO TO 10 SCNRM2 = ZERO GO TO 300 C 10 ASSIGN 30 TO NEXT SUM = ZERO NN = N * INCX C BEGIN MAIN LOOP DO 210 I=1,NN,INCX ABSX = ABS(REAL(CX(I))) IMAG = .FALSE. GO TO NEXT,(30, 50, 70, 90, 110) 30 IF( ABSX .GT. CUTLO) GO TO 85 ASSIGN 50 TO NEXT SCALE = .FALSE. C C PHASE 1. SUM IS ZERO C 50 IF( ABSX .EQ. ZERO) GO TO 200 IF( ABSX .GT. CUTLO) GO TO 85 C C PREPARE FOR PHASE 2. ASSIGN 70 TO NEXT GO TO 105 C C PREPARE FOR PHASE 4. C 100 ASSIGN 110 TO NEXT SUM = (SUM / ABSX) / ABSX 105 SCALE = .TRUE. XMAX = ABSX GO TO 115 C C PHASE 2. SUM IS SMALL. C SCALE TO AVOID DESTRUCTIVE UNDERFLOW. C 70 IF( ABSX .GT. CUTLO ) GO TO 75 C C COMMON CODE FOR PHASES 2 AND 4. C IN PHASE 4 SUM IS LARGE. SCALE TO AVOID OVERFLOW. C 110 IF( ABSX .LE. XMAX ) GO TO 115 SUM = ONE + SUM * (XMAX / ABSX)**2 XMAX = ABSX GO TO 200 C 115 SUM = SUM + (ABSX/XMAX)**2 GO TO 200 C C C PREPARE FOR PHASE 3. C 75 SUM = (SUM * XMAX) * XMAX C 85 ASSIGN 90 TO NEXT SCALE = .FALSE. C C FOR REAL OR D.P. SET HITEST = CUTHI/N C FOR COMPLEX SET HITEST = CUTHI/(2*N) C HITEST = CUTHI/FLOAT( N ) HITEST = HITEST * 0.5 C C PHASE 3. SUM IS MID-RANGE. NO SCALING. C 90 IF(ABSX .GE. HITEST) GO TO 100 SUM = SUM + ABSX**2 200 CONTINUE C CONTROL SELECTION OF REAL AND IMAGINARY PARTS. C IF(IMAG) GO TO 210 ABSX = ABS(AIMAG(CX(I))) IMAG = .TRUE. GO TO NEXT,( 50, 70, 90, 110 ) C 210 CONTINUE C C END OF MAIN LOOP. C COMPUTE SQUARE ROOT AND ADJUST FOR SCALING. C SCNRM2 = SQRT(SUM) IF(SCALE) SCNRM2 = SCNRM2 * XMAX 300 CONTINUE RETURN END INTEGER FUNCTION ISAMAX(N,SX,INCX) C C FINDS THE INDEX OF ELEMENT HAVING MAX. ABSOLUTE VALUE. C JACK DONGARRA, LINPACK, 3/11/78. C REAL SX(*),SMAX INTEGER I,INCX,IX,N C ISAMAX = 0 IF( N .LT. 1 ) RETURN ISAMAX = 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 SMAX = ABS(SX(1)) IX = IX + INCX DO 10 I = 2,N IF(ABS(SX(IX)).LE.SMAX) GO TO 5 ISAMAX = I SMAX = ABS(SX(IX)) 5 IX = IX + INCX 10 CONTINUE RETURN C C CODE FOR INCREMENT EQUAL TO 1 C 20 SMAX = ABS(SX(1)) DO 30 I = 2,N IF(ABS(SX(I)).LE.SMAX) GO TO 30 ISAMAX = I SMAX = ABS(SX(I)) 30 CONTINUE RETURN 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 DOUBLE PRECISION DX(*),DMAX INTEGER I,INCX,IX,N C IDAMAX = 0 IF( N .LT. 1 ) 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 INTEGER FUNCTION ICAMAX(N,CX,INCX) C C FINDS THE INDEX OF ELEMENT HAVING MAX. ABSOLUTE VALUE. C JACK DONGARRA, LINPACK, 3/11/78. C COMPLEX CX(*) REAL SMAX INTEGER I,INCX,IX,N COMPLEX ZDUM REAL CABS1 CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) C ICAMAX = 0 IF( N .LT. 1 ) RETURN ICAMAX = 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 SMAX = CABS1(CX(1)) IX = IX + INCX DO 10 I = 2,N IF(CABS1(CX(IX)).LE.SMAX) GO TO 5 ICAMAX = I SMAX = CABS1(CX(IX)) 5 IX = IX + INCX 10 CONTINUE RETURN C C CODE FOR INCREMENT EQUAL TO 1 C 20 SMAX = CABS1(CX(1)) DO 30 I = 2,N IF(CABS1(CX(I)).LE.SMAX) GO TO 30 ICAMAX = I SMAX = CABS1(CX(I)) 30 CONTINUE RETURN END SUBROUTINE MCVFS(A,KA,N,B) REAL A(KA,N),B(*) C L = 0 DO 20 J = 1,N DO 10 I = 1,J L = L + 1 10 B(L) = A(I,J) 20 CONTINUE RETURN END SUBROUTINE DMCVFS(A,KA,N,B) DOUBLE PRECISION A(KA,N),B(*) C L = 0 DO 20 J = 1,N DO 10 I = 1,J L = L + 1 10 B(L) = A(I,J) 20 CONTINUE RETURN END SUBROUTINE MCVSF(A,KA,N,B) REAL A(KA,N),B(*) C A(1,1) = B(1) IF (N .LT. 2) RETURN L = (N*(N + 1))/2 C J = N DO 11 JJ = 2,N I = J DO 10 II = 1,J A(I,J) = B(L) I = I - 1 10 L = L - 1 11 J = J - 1 C DO 21 I = 2,N IM1 = I - 1 DO 20 J = 1,IM1 20 A(I,J) = A(J,I) 21 CONTINUE RETURN END SUBROUTINE DMCVSF(A,KA,N,B) DOUBLE PRECISION A(KA,N),B(*) C A(1,1) = B(1) IF (N .LT. 2) RETURN L = (N*(N + 1))/2 C J = N DO 11 JJ = 2,N I = J DO 10 II = 1,J A(I,J) = B(L) I = I - 1 10 L = L - 1 11 J = J - 1 C DO 21 I = 2,N IM1 = I - 1 DO 20 J = 1,IM1 20 A(I,J) = A(J,I) 21 CONTINUE RETURN END SUBROUTINE MCVRD(M,N,A,KA,B,KB) REAL A(KA,N) DOUBLE PRECISION B(KB,N) C DO 20 J = 1,N DO 10 I = 1,M 10 B(I,J) = A(I,J) 20 CONTINUE RETURN END SUBROUTINE MCVDR(M,N,A,KA,B,KB) DOUBLE PRECISION A(KA,N) REAL B(KB,N) C DO 20 J = 1,N DO 10 I = 1,M 10 B(I,J) = A(I,J) 20 CONTINUE RETURN END SUBROUTINE MCVRC(M,N,A,KA,B,KB) REAL A(KA,N) COMPLEX B(KB,N) C DO 20 J = 1,N DO 10 I = 1,M 10 B(I,J) = CMPLX(A(I,J),0.0) 20 CONTINUE RETURN END SUBROUTINE CMREAL(M,N,A,KA,B,KB) COMPLEX A(KA,N) REAL B(KB,N) C DO 20 J = 1,N DO 10 I = 1,M 10 B(I,J) = REAL(A(I,J)) 20 CONTINUE RETURN END SUBROUTINE CMIMAG(M,N,A,KA,B,KB) COMPLEX A(KA,N) REAL B(KB,N) C DO 20 J = 1,N DO 10 I = 1,M 10 B(I,J) = AIMAG(A(I,J)) 20 CONTINUE RETURN END SUBROUTINE MCOPY(M,N,A,KA,B,KB) REAL A(KA,N),B(KB,N) C DO 20 J = 1,N DO 10 I = 1,M 10 B(I,J) = A(I,J) 20 CONTINUE RETURN END SUBROUTINE SMCOPY(N,A,B) REAL A(*),B(*) C L = (N*(N + 1))/2 DO 10 K = 1,L 10 B(K) = A(K) RETURN END SUBROUTINE DMCOPY(M,N,A,KA,B,KB) DOUBLE PRECISION A(KA,N),B(KB,N) C DO 20 J = 1,N DO 10 I = 1,M 10 B(I,J) = A(I,J) 20 CONTINUE RETURN END SUBROUTINE CMCOPY(M,N,A,KA,B,KB) COMPLEX A(KA,N),B(KB,N) C DO 20 J = 1,N DO 10 I = 1,M 10 B(I,J) = A(I,J) 20 CONTINUE RETURN END SUBROUTINE CMCONJ(M,N,A,KA,B,KB) COMPLEX A(KA,N),B(KB,N) C DO 20 J = 1,N DO 10 I = 1,M 10 B(I,J) = CONJG(A(I,J)) 20 CONTINUE RETURN END SUBROUTINE TPOSE(M,N,A,KA,B,KB) REAL A(KA,N),B(KB,M) C DO 20 J = 1,N DO 10 I = 1,M 10 B(J,I) = A(I,J) 20 CONTINUE RETURN END SUBROUTINE DTPOSE(M,N,A,KA,B,KB) DOUBLE PRECISION A(KA,N),B(KB,M) C DO 20 J = 1,N DO 10 I = 1,M 10 B(J,I) = A(I,J) 20 CONTINUE RETURN END SUBROUTINE CTPOSE(M,N,A,KA,B,KB) COMPLEX A(KA,N),B(KB,M) C DO 20 J = 1,N DO 10 I = 1,M 10 B(J,I) = A(I,J) 20 CONTINUE RETURN END SUBROUTINE TIP (A, N1, N2, MOVED, NWORK, NDIM) C ---------------------------------------------------------- C TRANSPOSITION OF A RECTANGULAR MATRIX IN SITU. C BY NORMAN BRENNER, MIT, 1/72. CF. ALG. 380, CACM, 5/70. C TRANSPOSITION OF THE N1 BY N2 MATRIX A AMOUNTS TO C REPLACING THE ELEMENT AT VECTOR POSITION I (0-ORIGIN) C WITH THE ELEMENT AT POSITION N1*I (MOD N1*N2-1). C EACH SUBCYCLE OF THIS PERMUTATION IS COMPLETED IN ORDER. C ---------------------------------------------------------- REAL A(*) REAL ATEMP, BTEMP INTEGER MOVED(NWORK) INTEGER IFACT(8), IPOWER(8), NEXP(8), IEXP(8) IF (N1.LT.2 .OR. N2.LT.2) GO TO 200 N12 = N1*N2 N = N1 M = N12 - 1 IF (N1.NE.N2) GO TO 30 C SQUARE MATRICES ARE DONE SEPARATELY FOR SPEED I1MIN = 2 DO 20 I1MAX=N,M,N I2 = I1MIN + N - 1 DO 10 I1=I1MIN,I1MAX ATEMP = A(I1) A(I1) = A(I2) A(I2) = ATEMP I2 = I2 + N 10 CONTINUE I1MIN = I1MIN + N + 1 20 CONTINUE RETURN C MODULUS M IS FACTORED INTO PRIME POWERS. EIGHT FACTORS C SUFFICE UP TO M = 2*3*5*7*11*13*17*19 = 9,767,520. 30 NDIM = 0 CALL INFCTR(M, IFACT, IPOWER, NEXP, NPOWER) DO 40 IP=1,NPOWER IEXP(IP) = 0 40 CONTINUE C GENERATE EVERY DIVISOR OF M LESS THAN M/2 IDIV = 1 MHALF = M/2 50 IF (IDIV.GE.MHALF) RETURN C THE NUMBER OF ELEMENTS WHOSE INDEX IS DIVISIBLE BY IDIV C AND BY NO OTHER DIVISOR OF M IS THE EULER TOTIENT C FUNCTION, PHI(M/IDIV). NCOUNT = M/IDIV DO 60 IP=1,NPOWER IF (IEXP(IP).EQ.NEXP(IP)) GO TO 60 NCOUNT = (NCOUNT/IFACT(IP))*(IFACT(IP)-1) 60 CONTINUE IF (NWORK.LE.0) GO TO 75 DO 70 I=1,NWORK MOVED(I) = 0 70 CONTINUE 75 ISTART = IDIV C THE STARTING POINT OF A SUBCYCLE IS DIVISIBLE ONLY BY IDIV C AND MUST NOT APPEAR IN ANY OTHER SUBCYCLE. 80 MMIST = M - ISTART IF (ISTART.EQ.IDIV) GO TO 120 NDIM = MAX0(NDIM,ISTART) IF (ISTART.GT.NWORK) GO TO 90 IF (MOVED(ISTART).NE.0) GO TO 160 90 ISOID = ISTART/IDIV DO 100 IP=1,NPOWER IF (IEXP(IP).EQ.NEXP(IP)) GO TO 100 IF (MOD(ISOID,IFACT(IP)).EQ.0) GO TO 160 100 CONTINUE IF (ISTART.LE.NWORK) GO TO 120 ITEST = ISTART 110 ITEST = MOD(N*ITEST,M) IF (ITEST.LT.ISTART .OR. ITEST.GT.MMIST) GO TO 160 IF (ITEST.GT.ISTART .AND. ITEST.LT.MMIST) GO TO 110 120 ATEMP = A(ISTART+1) BTEMP = A(MMIST+1) IA1 = ISTART 130 IA2 = MOD(N*IA1,M) MMIA1 = M - IA1 MMIA2 = M - IA2 IF (IA1.LE.NWORK) MOVED(IA1) = 1 IF (MMIA1.LE.NWORK) MOVED(MMIA1) = 1 NCOUNT = NCOUNT - 2 C MOVE TWO ELEMENTS, THE SECOND FROM THE NEGATIVE C SUBCYCLE. CHECK FIRST FOR SUBCYCLE CLOSURE. IF (IA2.EQ.ISTART) GO TO 140 IF (MMIA2.EQ.ISTART) GO TO 150 A(IA1+1) = A(IA2+1) A(MMIA1+1) = A(MMIA2+1) IA1 = IA2 GO TO 130 140 A(IA1+1) = ATEMP A(MMIA1+1) = BTEMP GO TO 160 150 A(IA1+1) = BTEMP A(MMIA1+1) = ATEMP 160 ISTART = ISTART + IDIV IF (NCOUNT.GT.0) GO TO 80 DO 180 IP=1,NPOWER IF (IEXP(IP).EQ.NEXP(IP)) GO TO 170 IEXP(IP) = IEXP(IP) + 1 IDIV = IDIV*IFACT(IP) GO TO 50 170 IEXP(IP) = 0 IDIV = IDIV/IPOWER(IP) 180 CONTINUE RETURN 200 IF (N1.NE.N2) NDIM = 0 RETURN END SUBROUTINE DTIP (A, N1, N2, MOVED, NWORK, NDIM) C ---------------------------------------------------------- C TRANSPOSITION OF A RECTANGULAR MATRIX IN SITU. C BY NORMAN BRENNER, MIT, 1/72. CF. ALG. 380, CACM, 5/70. C TRANSPOSITION OF THE N1 BY N2 MATRIX A AMOUNTS TO C REPLACING THE ELEMENT AT VECTOR POSITION I (0-ORIGIN) C WITH THE ELEMENT AT POSITION N1*I (MOD N1*N2-1). C EACH SUBCYCLE OF THIS PERMUTATION IS COMPLETED IN ORDER. C ---------------------------------------------------------- DOUBLE PRECISION A(*) DOUBLE PRECISION ATEMP, BTEMP INTEGER MOVED(NWORK) INTEGER IFACT(8), IPOWER(8), NEXP(8), IEXP(8) IF (N1.LT.2 .OR. N2.LT.2) GO TO 200 N12 = N1*N2 N = N1 M = N12 - 1 IF (N1.NE.N2) GO TO 30 C SQUARE MATRICES ARE DONE SEPARATELY FOR SPEED I1MIN = 2 DO 20 I1MAX=N,M,N I2 = I1MIN + N - 1 DO 10 I1=I1MIN,I1MAX ATEMP = A(I1) A(I1) = A(I2) A(I2) = ATEMP I2 = I2 + N 10 CONTINUE I1MIN = I1MIN + N + 1 20 CONTINUE RETURN C MODULUS M IS FACTORED INTO PRIME POWERS. EIGHT FACTORS C SUFFICE UP TO M = 2*3*5*7*11*13*17*19 = 9,767,520. 30 NDIM = 0 CALL INFCTR(M, IFACT, IPOWER, NEXP, NPOWER) DO 40 IP=1,NPOWER IEXP(IP) = 0 40 CONTINUE C GENERATE EVERY DIVISOR OF M LESS THAN M/2 IDIV = 1 MHALF = M/2 50 IF (IDIV.GE.MHALF) RETURN C THE NUMBER OF ELEMENTS WHOSE INDEX IS DIVISIBLE BY IDIV C AND BY NO OTHER DIVISOR OF M IS THE EULER TOTIENT C FUNCTION, PHI(M/IDIV). NCOUNT = M/IDIV DO 60 IP=1,NPOWER IF (IEXP(IP).EQ.NEXP(IP)) GO TO 60 NCOUNT = (NCOUNT/IFACT(IP))*(IFACT(IP)-1) 60 CONTINUE IF (NWORK.LE.0) GO TO 75 DO 70 I=1,NWORK MOVED(I) = 0 70 CONTINUE 75 ISTART = IDIV C THE STARTING POINT OF A SUBCYCLE IS DIVISIBLE ONLY BY IDIV C AND MUST NOT APPEAR IN ANY OTHER SUBCYCLE. 80 MMIST = M - ISTART IF (ISTART.EQ.IDIV) GO TO 120 NDIM = MAX0(NDIM,ISTART) IF (ISTART.GT.NWORK) GO TO 90 IF (MOVED(ISTART).NE.0) GO TO 160 90 ISOID = ISTART/IDIV DO 100 IP=1,NPOWER IF (IEXP(IP).EQ.NEXP(IP)) GO TO 100 IF (MOD(ISOID,IFACT(IP)).EQ.0) GO TO 160 100 CONTINUE IF (ISTART.LE.NWORK) GO TO 120 ITEST = ISTART 110 ITEST = MOD(N*ITEST,M) IF (ITEST.LT.ISTART .OR. ITEST.GT.MMIST) GO TO 160 IF (ITEST.GT.ISTART .AND. ITEST.LT.MMIST) GO TO 110 120 ATEMP = A(ISTART+1) BTEMP = A(MMIST+1) IA1 = ISTART 130 IA2 = MOD(N*IA1,M) MMIA1 = M - IA1 MMIA2 = M - IA2 IF (IA1.LE.NWORK) MOVED(IA1) = 1 IF (MMIA1.LE.NWORK) MOVED(MMIA1) = 1 NCOUNT = NCOUNT - 2 C MOVE TWO ELEMENTS, THE SECOND FROM THE NEGATIVE C SUBCYCLE. CHECK FIRST FOR SUBCYCLE CLOSURE. IF (IA2.EQ.ISTART) GO TO 140 IF (MMIA2.EQ.ISTART) GO TO 150 A(IA1+1) = A(IA2+1) A(MMIA1+1) = A(MMIA2+1) IA1 = IA2 GO TO 130 140 A(IA1+1) = ATEMP A(MMIA1+1) = BTEMP GO TO 160 150 A(IA1+1) = BTEMP A(MMIA1+1) = ATEMP 160 ISTART = ISTART + IDIV IF (NCOUNT.GT.0) GO TO 80 DO 180 IP=1,NPOWER IF (IEXP(IP).EQ.NEXP(IP)) GO TO 170 IEXP(IP) = IEXP(IP) + 1 IDIV = IDIV*IFACT(IP) GO TO 50 170 IEXP(IP) = 0 IDIV = IDIV/IPOWER(IP) 180 CONTINUE RETURN 200 IF (N1.NE.N2) NDIM = 0 RETURN END SUBROUTINE CTIP (A, N1, N2, MOVED, NWORK, NDIM) C ---------------------------------------------------------- C TRANSPOSITION OF A RECTANGULAR MATRIX IN SITU. C BY NORMAN BRENNER, MIT, 1/72. CF. ALG. 380, CACM, 5/70. C TRANSPOSITION OF THE N1 BY N2 MATRIX A AMOUNTS TO C REPLACING THE ELEMENT AT VECTOR POSITION I (0-ORIGIN) C WITH THE ELEMENT AT POSITION N1*I (MOD N1*N2-1). C EACH SUBCYCLE OF THIS PERMUTATION IS COMPLETED IN ORDER. C ---------------------------------------------------------- COMPLEX A(*) COMPLEX ATEMP, BTEMP INTEGER MOVED(NWORK) INTEGER IFACT(8), IPOWER(8), NEXP(8), IEXP(8) IF (N1.LT.2 .OR. N2.LT.2) GO TO 200 N12 = N1*N2 N = N1 M = N12 - 1 IF (N1.NE.N2) GO TO 30 C SQUARE MATRICES ARE DONE SEPARATELY FOR SPEED I1MIN = 2 DO 20 I1MAX=N,M,N I2 = I1MIN + N - 1 DO 10 I1=I1MIN,I1MAX ATEMP = A(I1) A(I1) = A(I2) A(I2) = ATEMP I2 = I2 + N 10 CONTINUE I1MIN = I1MIN + N + 1 20 CONTINUE RETURN C MODULUS M IS FACTORED INTO PRIME POWERS. EIGHT FACTORS C SUFFICE UP TO M = 2*3*5*7*11*13*17*19 = 9,767,520. 30 NDIM = 0 CALL INFCTR(M, IFACT, IPOWER, NEXP, NPOWER) DO 40 IP=1,NPOWER IEXP(IP) = 0 40 CONTINUE C GENERATE EVERY DIVISOR OF M LESS THAN M/2 IDIV = 1 MHALF = M/2 50 IF (IDIV.GE.MHALF) RETURN C THE NUMBER OF ELEMENTS WHOSE INDEX IS DIVISIBLE BY IDIV C AND BY NO OTHER DIVISOR OF M IS THE EULER TOTIENT C FUNCTION, PHI(M/IDIV). NCOUNT = M/IDIV DO 60 IP=1,NPOWER IF (IEXP(IP).EQ.NEXP(IP)) GO TO 60 NCOUNT = (NCOUNT/IFACT(IP))*(IFACT(IP)-1) 60 CONTINUE IF (NWORK.LE.0) GO TO 75 DO 70 I=1,NWORK MOVED(I) = 0 70 CONTINUE 75 ISTART = IDIV C THE STARTING POINT OF A SUBCYCLE IS DIVISIBLE ONLY BY IDIV C AND MUST NOT APPEAR IN ANY OTHER SUBCYCLE. 80 MMIST = M - ISTART IF (ISTART.EQ.IDIV) GO TO 120 NDIM = MAX0(NDIM,ISTART) IF (ISTART.GT.NWORK) GO TO 90 IF (MOVED(ISTART).NE.0) GO TO 160 90 ISOID = ISTART/IDIV DO 100 IP=1,NPOWER IF (IEXP(IP).EQ.NEXP(IP)) GO TO 100 IF (MOD(ISOID,IFACT(IP)).EQ.0) GO TO 160 100 CONTINUE IF (ISTART.LE.NWORK) GO TO 120 ITEST = ISTART 110 ITEST = MOD(N*ITEST,M) IF (ITEST.LT.ISTART .OR. ITEST.GT.MMIST) GO TO 160 IF (ITEST.GT.ISTART .AND. ITEST.LT.MMIST) GO TO 110 120 ATEMP = A(ISTART+1) BTEMP = A(MMIST+1) IA1 = ISTART 130 IA2 = MOD(N*IA1,M) MMIA1 = M - IA1 MMIA2 = M - IA2 IF (IA1.LE.NWORK) MOVED(IA1) = 1 IF (MMIA1.LE.NWORK) MOVED(MMIA1) = 1 NCOUNT = NCOUNT - 2 C MOVE TWO ELEMENTS, THE SECOND FROM THE NEGATIVE C SUBCYCLE. CHECK FIRST FOR SUBCYCLE CLOSURE. IF (IA2.EQ.ISTART) GO TO 140 IF (MMIA2.EQ.ISTART) GO TO 150 A(IA1+1) = A(IA2+1) A(MMIA1+1) = A(MMIA2+1) IA1 = IA2 GO TO 130 140 A(IA1+1) = ATEMP A(MMIA1+1) = BTEMP GO TO 160 150 A(IA1+1) = BTEMP A(MMIA1+1) = ATEMP 160 ISTART = ISTART + IDIV IF (NCOUNT.GT.0) GO TO 80 DO 180 IP=1,NPOWER IF (IEXP(IP).EQ.NEXP(IP)) GO TO 170 IEXP(IP) = IEXP(IP) + 1 IDIV = IDIV*IFACT(IP) GO TO 50 170 IEXP(IP) = 0 IDIV = IDIV/IPOWER(IP) 180 CONTINUE RETURN 200 IF (N1.NE.N2) NDIM = 0 RETURN END SUBROUTINE INFCTR(N, IFACT, IPOWER, NEXP, NPOWER) C FACTOR N INTO ITS PRIME POWERS, NPOWER IN NUMBER. C E.G., FOR N=1960=2**3 *5 *7**2, NPOWER=3, IFACT=2,5,7, C IPOWER=8,5,49, AND NEXP=3,1,2. DIMENSION IFACT(*), IPOWER(*), NEXP(*) IP = 0 IFCUR = 0 NPART = N IDIV = 2 10 IQUOT = NPART/IDIV IF (NPART-IDIV*IQUOT) 60, 20, 60 20 IF (IDIV-IFCUR) 40, 40, 30 30 IP = IP + 1 IFACT(IP) = IDIV IPOWER(IP) = IDIV IFCUR = IDIV NEXP(IP) = 1 GO TO 50 40 IPOWER(IP) = IDIV*IPOWER(IP) NEXP(IP) = NEXP(IP) + 1 50 NPART = IQUOT GO TO 10 60 IF (IQUOT-IDIV) 100, 100, 70 70 IF (IDIV-2) 80, 80, 90 80 IDIV = 3 GO TO 10 90 IDIV = IDIV + 2 GO TO 10 100 IF (NPART-1) 140, 140, 110 110 IF (NPART-IFCUR) 130, 130, 120 120 IP = IP + 1 IFACT(IP) = NPART IPOWER(IP) = NPART NEXP(IP) = 1 GO TO 140 130 IPOWER(IP) = NPART*IPOWER(IP) NEXP(IP) = NEXP(IP) + 1 140 NPOWER = IP RETURN END SUBROUTINE CMADJ(M,N,A,KA,B,KB) COMPLEX A(KA,N),B(KB,M) C DO 20 J = 1,N DO 10 I = 1,M 10 B(J,I) = CONJG(A(I,J)) 20 CONTINUE RETURN END SUBROUTINE CTRANS (NM, N, A) C C C SUBROUTINE CTRANS FINDS THE COMPLEX CONJUGATE OF AN INPUT C MATRIX. C C C ON ENTRY, C C NM IS THE LEADING DIMENSION OF MATRIX A IN THE MAIN PROGRAM. C C N IS THE ORDER OF MATRIX A. C C A IS THE INPUT MATRIX. C C C ON RETURN, C C A CONTAINS ITS CONJUGATE TRANSPOSE. C C INTEGER I, J, N, NM COMPLEX A(NM,N), TEMP C DO 20 I = 1,N DO 10 J = I,N TEMP = A(I,J) A(I,J) = CONJG(A(J,I)) A(J,I) = CONJG(TEMP) 10 CONTINUE 20 CONTINUE RETURN END SUBROUTINE MADD (M, N, A, KA, B, KB, C, KC) C----------------------------------------------------------------------- C ADDITION OF REAL MATRICES C----------------------------------------------------------------------- REAL A(KA,N), B(KB,N), C(KC,N) C DO 20 J = 1,N DO 10 I = 1,M C(I,J) = A(I,J) + B(I,J) 10 CONTINUE 20 CONTINUE RETURN END SUBROUTINE DMADD (M, N, A, KA, B, KB, C, KC) C----------------------------------------------------------------------- C ADDITION OF DOUBLE PRECISION MATRICES C----------------------------------------------------------------------- DOUBLE PRECISION A(KA,N), B(KB,N), C(KC,N) C DO 20 J = 1,N DO 10 I = 1,M C(I,J) = A(I,J) + B(I,J) 10 CONTINUE 20 CONTINUE RETURN END SUBROUTINE CMADD (M, N, A, KA, B, KB, C, KC) C----------------------------------------------------------------------- C ADDITION OF COMPLEX MATRICES C----------------------------------------------------------------------- COMPLEX A(KA,N), B(KB,N), C(KC,N) C DO 20 J = 1,N DO 10 I = 1,M C(I,J) = A(I,J) + B(I,J) 10 CONTINUE 20 CONTINUE RETURN END SUBROUTINE SMADD(N,A,B,C) REAL A(*),B(*),C(*) M=(N*(N+1))/2 DO 10 K=1,M 10 C(K)=A(K)+B(K) RETURN END SUBROUTINE MSUBT (M, N, A, KA, B, KB, C, KC) C----------------------------------------------------------------------- C SUBTRACTION OF REAL MATRICES C----------------------------------------------------------------------- REAL A(KA,N), B(KB,N), C(KC,N) C DO 20 J = 1,N DO 10 I = 1,M C(I,J) = A(I,J) - B(I,J) 10 CONTINUE 20 CONTINUE RETURN END SUBROUTINE DMSUBT (M, N, A, KA, B, KB, C, KC) C----------------------------------------------------------------------- C SUBTRACTION OF DOUBLE PRECISION MATRICES C----------------------------------------------------------------------- DOUBLE PRECISION A(KA,N), B(KB,N), C(KC,N) C DO 20 J = 1,N DO 10 I = 1,M C(I,J) = A(I,J) - B(I,J) 10 CONTINUE 20 CONTINUE RETURN END SUBROUTINE CMSUBT (M, N, A, KA, B, KB, C, KC) C----------------------------------------------------------------------- C SUBTRACTION OF COMPLEX MATRICES C----------------------------------------------------------------------- COMPLEX A(KA,N), B(KB,N), C(KC,N) C DO 20 J = 1,N DO 10 I = 1,M C(I,J) = A(I,J) - B(I,J) 10 CONTINUE 20 CONTINUE RETURN END SUBROUTINE SMSUBT(N,A,B,C) REAL A(*),B(*),C(*) M=(N*(N+1))/2 DO 10 K=1,M 10 C(K)=A(K)-B(K) RETURN END SUBROUTINE MTMS (M, N, L, A, KA, B, KB, C, KC) C----------------------------------------------------------------------- C PRODUCT OF REAL MATRICES C----------------------------------------------------------------------- REAL A(KA,N), B(KB,L), C(KC,L) DOUBLE PRECISION W C DO 30 J = 1,L DO 20 I = 1,M W = 0.D0 DO 10 K = 1,N W = W + DBLE(A(I,K))*DBLE(B(K,J)) 10 CONTINUE C(I,J) = W 20 CONTINUE 30 CONTINUE RETURN END SUBROUTINE DMTMS (M, N, L, A, KA, B, KB, C, KC) C----------------------------------------------------------------------- C PRODUCT OF DOUBLE PRECISION MATRICES C----------------------------------------------------------------------- DOUBLE PRECISION A(KA,N), B(KB,L), C(KC,L), W C DO 30 J = 1,L DO 20 I = 1,M W = 0.D0 DO 10 K = 1,N W = W + A(I,K)*B(K,J) 10 CONTINUE C(I,J) = W 20 CONTINUE 30 CONTINUE RETURN END SUBROUTINE CMTMS (M, N, L, A, KA, B, KB, C, KC) C----------------------------------------------------------------------- C PRODUCT OF COMPLEX MATRICES C----------------------------------------------------------------------- COMPLEX A(KA,N), B(KB,L), C(KC,L), W C DO 30 J = 1,L DO 20 I = 1,M W = (0.0,0.0) DO 10 K = 1,N W = W + A(I,K)*B(K,J) 10 CONTINUE C(I,J) = W 20 CONTINUE 30 CONTINUE RETURN END SUBROUTINE MPROD (M, N, L, A, KA, B, KB, C, KC, ROW) C----------------------------------------------------------------------- C PRODUCT OF REAL MATRICES C----------------------------------------------------------------------- REAL A(KA,N), B(KB,L), C(KC,L), ROW(*) DOUBLE PRECISION W LOGICAL RLOC C SAVE = C(1,1) C(1,1) = 1.0 IF (RLOC(C,A)) GO TO 20 IF (RLOC(C,B)) GO TO 30 C DO 12 J = 1,L DO 11 I = 1,M W = 0.D0 DO 10 K = 1,N 10 W = W + DBLE(A(I,K))*DBLE(B(K,J)) 11 C(I,J) = W 12 CONTINUE RETURN C C HERE C BEGINS IN THE SAME LOCATION AS A. THE DIMENSION OF ROW C MUST BE GREATER THAN OR EQUAL TO L. IT IS ASSUMED THAT KC=KA. C 20 A(1,1) = SAVE DO 24 I = 1,M DO 22 J = 1,L W = 0.D0 DO 21 K = 1,N 21 W = W + DBLE(A(I,K))*DBLE(B(K,J)) 22 ROW(J) = W DO 23 J = 1,L 23 A(I,J) = ROW(J) 24 CONTINUE RETURN C C HERE C BEGINS IN THE SAME LOCATION AS B. THE DIMENSION OF ROW C MUST BE GREATER THAN OR EQUAL TO M. IT IS ASSUMED THAT KC=KB. C 30 B(1,1) = SAVE DO 34 J = 1,L DO 32 I = 1,M W = 0.D0 DO 31 K = 1,N 31 W = W + DBLE(A(I,K))*DBLE(B(K,J)) 32 ROW(I) = W DO 33 I = 1,M 33 B(I,J) = ROW(I) 34 CONTINUE RETURN END LOGICAL FUNCTION RLOC (X, Y) C----------------------------------------------------------------------- C X AND Y ARE ARRAYS. IT IS ASSUMED THAT X(1) AND Y(1) CONTAIN DATA. C C RLOC(X,Y) = .TRUE. IF X AND Y BEGIN IN THE SAME LOCATION C RLOC(X,Y) = .FALSE. IF X AND Y BEGIN IN DIFFERENT LOCATIONS C C IT IS RECOMMENDED THAT THIS CODING NOT BE OPTIMIZED BY ELIMINATING C THE SUBROUTINE YCHG. IF IT IS OPTIMIZED THEN RLOC MAY NOT COMPILE C PROPERLY. C----------------------------------------------------------------------- REAL X(*), Y(*) C XOLD = X(1) YOLD = Y(1) CALL YCHG(X,Y,YOLD) IF (X(1) .EQ. XOLD) GO TO 10 C C X AND Y BEGIN IN THE SAME LOCATION C Y(1) = YOLD RLOC = .TRUE. RETURN C C X AND Y BEGIN IN DIFFERENT LOCATIONS C 10 Y(1) = YOLD RLOC = .FALSE. RETURN END SUBROUTINE YCHG (X, Y, YOLD) REAL X(*), Y(*) C Y(1) = 0.0 IF (YOLD .EQ. 0.0) Y(1) = 1.0 RETURN END SUBROUTINE DMPROD (M, N, L, A, KA, B, KB, C, KC, ROW) C----------------------------------------------------------------------- C PRODUCT OF DOUBLE PRECISION MATRICES C----------------------------------------------------------------------- DOUBLE PRECISION A(KA,N), B(KB,L), C(KC,L), ROW(*), W LOGICAL DLOC C W = C(1,1) C(1,1) = 1.D0 IF (DLOC(C,A)) GO TO 20 IF (DLOC(C,B)) GO TO 30 C DO 12 J = 1,L DO 11 I = 1,M W = 0.D0 DO 10 K = 1,N 10 W = W + A(I,K)*B(K,J) 11 C(I,J) = W 12 CONTINUE RETURN C C HERE C BEGINS IN THE SAME LOCATION AS A. THE DIMENSION OF ROW C MUST BE GREATER THAN OR EQUAL TO L. IT IS ASSUMED THAT KC=KA. C 20 A(1,1) = W DO 24 I = 1,M DO 22 J = 1,L W = 0.D0 DO 21 K = 1,N 21 W = W + A(I,K)*B(K,J) 22 ROW(J) = W DO 23 J = 1,L 23 A(I,J) = ROW(J) 24 CONTINUE RETURN C C HERE C BEGINS IN THE SAME LOCATION AS B. THE DIMENSION OF ROW C MUST BE GREATER THAN OR EQUAL TO M. IT IS ASSUMED THAT KC=KB. C 30 B(1,1) = W DO 34 J = 1,L DO 32 I = 1,M W = 0.D0 DO 31 K = 1,N 31 W = W + A(I,K)*B(K,J) 32 ROW(I) = W DO 33 I = 1,M 33 B(I,J) = ROW(I) 34 CONTINUE RETURN END LOGICAL FUNCTION DLOC (X, Y) C----------------------------------------------------------------------- C X AND Y ARE ARRAYS. IT IS ASSUMED THAT X(1) AND Y(1) CONTAIN DATA. C C DLOC(X,Y) = .TRUE. IF X AND Y BEGIN IN THE SAME LOCATION C DLOC(X,Y) = .FALSE. IF X AND Y BEGIN IN DIFFERENT LOCATIONS C C IT IS RECOMMENDED THAT THIS CODING NOT BE OPTIMIZED BY ELIMINATING C THE SUBROUTINE DYCHG. IF IT IS OPTIMIZED THEN DLOC MAY NOT COMPILE C PROPERLY. C----------------------------------------------------------------------- DOUBLE PRECISION X(*), Y(*), XOLD, YOLD C XOLD = X(1) YOLD = Y(1) CALL DYCHG(X,Y,YOLD) IF (X(1) .EQ. XOLD) GO TO 10 C C X AND Y BEGIN IN THE SAME LOCATION C Y(1) = YOLD DLOC = .TRUE. RETURN C C X AND Y BEGIN IN DIFFERENT LOCATIONS C 10 Y(1) = YOLD DLOC = .FALSE. RETURN END SUBROUTINE DYCHG (X, Y, YOLD) DOUBLE PRECISION X(*), Y(*), YOLD C Y(1) = 0.D0 IF (YOLD .EQ. 0.D0) Y(1) = 1.D0 RETURN END SUBROUTINE CMPROD (M, N, L, A, KA, B, KB, C, KC, ROW) C----------------------------------------------------------------------- C PRODUCT OF COMPLEX MATRICES C----------------------------------------------------------------------- COMPLEX A(KA,N), B(KB,L), C(KC,L), ROW(*), W LOGICAL CLOC C W = C(1,1) C(1,1) = (1.0,0.0) IF (CLOC(C,A)) GO TO 20 IF (CLOC(C,B)) GO TO 30 C DO 12 J = 1,L DO 11 I = 1,M W = (0.0,0.0) DO 10 K = 1,N 10 W = W + A(I,K)*B(K,J) 11 C(I,J) = W 12 CONTINUE RETURN C C HERE C BEGINS IN THE SAME LOCATION AS A. THE DIMENSION OF ROW C MUST BE GREATER THAN OR EQUAL TO L. IT IS ASSUMED THAT KC=KA. C 20 A(1,1) = W DO 24 I = 1,M DO 22 J = 1,L W = (0.0,0.0) DO 21 K = 1,N 21 W = W + A(I,K)*B(K,J) 22 ROW(J) = W DO 23 J = 1,L 23 A(I,J) = ROW(J) 24 CONTINUE RETURN C C HERE C BEGINS IN THE SAME LOCATION AS B. THE DIMENSION OF ROW C MUST BE GREATER THAN OR EQUAL TO M. IT IS ASSUMED THAT KC=KB. C 30 B(1,1) = W DO 34 J = 1,L DO 32 I = 1,M W = (0.0,0.0) DO 31 K = 1,N 31 W = W + A(I,K)*B(K,J) 32 ROW(I) = W DO 33 I = 1,M 33 B(I,J) = ROW(I) 34 CONTINUE RETURN END LOGICAL FUNCTION CLOC (X, Y) C----------------------------------------------------------------------- C X AND Y ARE ARRAYS. IT IS ASSUMED THAT X(1) AND Y(1) CONTAIN DATA. C C CLOC(X,Y) = .TRUE. IF X AND Y BEGIN IN THE SAME LOCATION C CLOC(X,Y) = .FALSE. IF X AND Y BEGIN IN DIFFERENT LOCATIONS C C IT IS RECOMMENDED THAT THIS CODING NOT BE OPTIMIZED BY ELIMINATING C THE SUBROUTINE CYCHG. IF IT IS OPTIMIZED THEN CLOC MAY NOT COMPILE C PROPERLY. C----------------------------------------------------------------------- COMPLEX X(*), Y(*), XOLD, YOLD C XOLD = X(1) YOLD = Y(1) CALL CYCHG(X,Y,YOLD) IF (X(1) .EQ. XOLD) GO TO 10 C C X AND Y BEGIN IN THE SAME LOCATION C Y(1) = YOLD CLOC = .TRUE. RETURN C C X AND Y BEGIN IN DIFFERENT LOCATIONS C 10 Y(1) = YOLD CLOC = .FALSE. RETURN END SUBROUTINE CYCHG (X, Y, YOLD) COMPLEX X(*), Y(*), YOLD COMPLEX ZERO, ONE DATA ZERO/(0.0,0.0)/, ONE/(1.0,0.0)/ C Y(1) = ZERO IF (YOLD .EQ. ZERO) Y(1) = ONE RETURN END SUBROUTINE SVPRD(A,N,X,Y) REAL A(*),X(N),Y(N) Y(1) = A(1)*X(1) IF (N .EQ. 1) RETURN C L = 1 DO 20 K = 2,N KM1 = K - 1 XK = X(K) YK = 0.0 C DO 10 I = 1,KM1 L = L + 1 Y(I) = Y(I) + A(L)*XK 10 YK = YK + A(L)*X(I) C L = L + 1 20 Y(K) = YK + A(L)*XK RETURN END SUBROUTINE DSVPRD(A,N,X,Y) DOUBLE PRECISION A(*),X(N),Y(N) DOUBLE PRECISION XK,YK Y(1) = A(1)*X(1) IF (N .EQ. 1) RETURN C L = 1 DO 20 K = 2,N KM1 = K - 1 XK = X(K) YK = 0.D0 C DO 10 I = 1,KM1 L = L + 1 Y(I) = Y(I) + A(L)*XK 10 YK = YK + A(L)*X(I) C L = L + 1 20 Y(K) = YK + A(L)*XK RETURN END SUBROUTINE TMPROD(M,N,L,A,KA,B,KB,C,KC) REAL A(KA,N),B(KB,L),C(KC,L) DOUBLE PRECISION S DO 12 J=1,L DO 11 I=1,N S = 0.D0 DO 10 K=1,M 10 S = S + DBLE(A(K,I))*DBLE(B(K,J)) 11 C(I,J) = S 12 CONTINUE RETURN END SUBROUTINE SMPROD(M,N,A,KA,B) REAL A(KA,N),B(*) DOUBLE PRECISION S II=1 DO 12 I=1,N DO 11 J=1,I S = 0.D0 DO 10 K=1,M 10 S = S + DBLE(A(K,I))*DBLE(A(K,J)) B(II) = S 11 II = II + 1 12 CONTINUE RETURN END SUBROUTINE KPROD(A,KA,M,N,B,KB,K,L,C,KC) C ****************************************************************** C KRONECKER PRODUCT OF REAL MATRICES A AND B C ****************************************************************** REAL A(KA,N),B(KB,L),C(KC,*) INTEGER R,S C J = 0 DO 40 S = 1,N DO 30 JJ = 1,L J = J + 1 C C COMPUTE THE J-TH COLUMN OF C C I = 0 DO 20 R = 1,M DO 10 II = 1,K I = I + 1 10 C(I,J) = A(R,S)*B(II,JJ) 20 CONTINUE C 30 CONTINUE 40 CONTINUE RETURN END SUBROUTINE DKPROD(A,KA,M,N,B,KB,K,L,C,KC) C ****************************************************************** C KRONECKER PRODUCT OF DOUBLE PRECISION MATRICES A AND B C ****************************************************************** DOUBLE PRECISION A(KA,N),B(KB,L),C(KC,*) INTEGER R,S C J = 0 DO 40 S = 1,N DO 30 JJ = 1,L J = J + 1 C C COMPUTE THE J-TH COLUMN OF C C I = 0 DO 20 R = 1,M DO 10 II = 1,K I = I + 1 10 C(I,J) = A(R,S)*B(II,JJ) 20 CONTINUE C 30 CONTINUE 40 CONTINUE RETURN END SUBROUTINE CKPROD(A,KA,M,N,B,KB,K,L,C,KC) C ****************************************************************** C KRONECKER PRODUCT OF COMPLEX MATRICES A AND B C ****************************************************************** COMPLEX A(KA,N),B(KB,L),C(KC,*) INTEGER R,S C J = 0 DO 40 S = 1,N DO 30 JJ = 1,L J = J + 1 C C COMPUTE THE J-TH COLUMN OF C C I = 0 DO 20 R = 1,M DO 10 II = 1,K I = I + 1 10 C(I,J) = A(R,S)*B(II,JJ) 20 CONTINUE C 30 CONTINUE 40 CONTINUE RETURN END SUBROUTINE RNK (A, MDA, M, N, RE, AE, KRANK, KSURE, WORK, IWORK) C----------------------------------------------------------------------- C C UPPER AND LOWER BOUNDS OF THE RANK OF A REAL MATRIX C C----------------------------------------------------------------------- C REAL WORK(5*M0) WHERE M0 = 5*MIN0(M,N) C INTEGER IWORK(M + N) C-------------------- REAL A(MDA,N), WORK(*) INTEGER IWORK(*) C M0 = MIN0(M,N) C C DEFINE THE RELATIVE AND ABSOLUTE TOLERANCE LISTS C M1 = 1 M2 = M1 + M0 M3 = M2 + M0 M4 = M3 + M0 M5 = M4 + M0 C EPS = 10.0*SPMPAR(1) RERR = AMAX1(EPS,RE) C IMAX = M5 - 1 DO 20 I = M4,IMAX WORK(I) = RERR 20 CONTINUE IMAX = IMAX + M0 DO 30 I = M5,IMAX WORK(I) = AE 30 CONTINUE C C FACTOR THE MATRIX A C IF (M .LT. N) GO TO 40 C CALL U11LS (A,MDA,M,N,WORK(M4),WORK(M5),1,0,KRANK,KSURE, * WORK(M1),WORK(M2),WORK(M3),IWORK(M1),IWORK(M2)) RETURN C 40 CALL U11US (A,MDA,M,N,WORK(M4),WORK(M5),1,0,KRANK,KSURE, * WORK(M1),WORK(M2),WORK(M3),IWORK(M1),IWORK(M2)) RETURN END SUBROUTINE DRNK (A, MDA, M, N, RE, AE, KRANK, KSURE, WORK, IWORK) C----------------------------------------------------------------------- C C UPPER AND LOWER BOUNDS OF THE RANK OF A C DOUBLE PRECISION MATRIX C C----------------------------------------------------------------------- C DOUBLE PRECISION WORK(5*M0) WHERE M0 = 5*MIN0(M,N) C INTEGER IWORK(M + N) C-------------------- DOUBLE PRECISION A(MDA,N), RE, AE, WORK(*) INTEGER IWORK(*) DOUBLE PRECISION EPS, RERR DOUBLE PRECISION DPMPAR C M0 = MIN0(M,N) C C DEFINE THE RELATIVE AND ABSOLUTE TOLERANCE LISTS C M1 = 1 M2 = M1 + M0 M3 = M2 + M0 M4 = M3 + M0 M5 = M4 + M0 C EPS = 10.D0*DPMPAR(1) RERR = DMAX1(EPS,RE) C IMAX = M5 - 1 DO 20 I = M4,IMAX WORK(I) = RERR 20 CONTINUE IMAX = IMAX + M0 DO 30 I = M5,IMAX WORK(I) = AE 30 CONTINUE C C FACTOR THE MATRIX A C IF (M .LT. N) GO TO 40 C CALL DU11LS (A,MDA,M,N,WORK(M4),WORK(M5),1,0,KRANK,KSURE, * WORK(M1),WORK(M2),WORK(M3),IWORK(M1),IWORK(M2)) RETURN C 40 CALL DU11US (A,MDA,M,N,WORK(M4),WORK(M5),1,0,KRANK,KSURE, * WORK(M1),WORK(M2),WORK(M3),IWORK(M1),IWORK(M2)) RETURN END SUBROUTINE CROUT(MO,N,M,A,KA,B,KB,D,INDEX,TEMP) C----------------------------------------------------------------------- C CROUT PROCEDURE FOR INVERTING MATRICES AND SOLVING EQUATIONS C----------------------------------------------------------------------- C A IS A MATRIX OF ORDER N WHERE N IS GREATER THAN OR EQUAL TO 1. C IF MO=0 THEN THE INVERSE OF A IS COMPUTED AND STORED IN A. IF MO C IS NOT 0 THEN THE INVERSE IS NOT COMPUTED. C C IF M IS GREATER THAN 0 THEN B IS A MATRIX HAVING N ROWS AND M C COLUMNS. IN THIS CASE AX=B IS SOLVED AND THE SOLUTION X IS STORED C IN B. IF M=0 THEN THERE ARE NO EQUATIONS TO BE SOLVED. C C KA = THE LENGTH OF THE COLUMNS OF THE ARRAY A C KB = THE LENGTH OF THE COLUMNS OF THE ARRAY B (IF M.GT.0) C C THE DETERMINANT D OF A IS ALWAYS COMPUTED. IF D=0 THEN THE C ROUTINE IMMEDIATELY TERMINATES. C C INDEX IS AN ARRAY OF DIMENSION N-1 OR LARGER THAT IS USED BY THE C ROUTINE FOR KEEPING TRACK OF THE ROW INTERCHANGES THAT ARE MADE. C IF MO IS NOT 0 THEN THIS ARRAY IS NOT NEEDED. C C TEMP IS AN ARRAY OF DIMENSION N OR LARGER THAT IS USED WHEN A C IS INVERTED. IF MO IS NOT 0 THEN THIS ARRAY IS NOT NEEDED. C----------------------------------------------------------------------- DIMENSION A(KA,N), B(*), INDEX(*), TEMP(*) INTEGER ONEJ DOUBLE PRECISION DSUM C IF (N .LT. 2) GO TO 200 D = 1.0 NM1 = N - 1 DO 70 K = 1,NM1 KP1 = K + 1 C C SEARCH FOR THE K-TH PIVOT ELEMENT C P = ABS(A(K,K)) L = K DO 10 I = KP1,N T = ABS(A(I,K)) IF (P .GE. T) GO TO 10 P = T L = I 10 CONTINUE C P = A(L,K) D = P*D IF (D .EQ. 0.0) RETURN IF (MO .EQ. 0) INDEX(K) = L IF (K .EQ. L) GO TO 40 D = -D C C INTERCHANGING ROWS K AND L C DO 20 J = 1,N T = A(K,J) A(K,J) = A(L,J) 20 A(L,J) = T C IF (M .LE. 0) GO TO 40 KJ = K LJ = L DO 30 J = 1,M T = B(KJ) B(KJ) = B(LJ) B(LJ) = T KJ = KJ + KB 30 LJ = LJ + KB C C COMPUTE THE K-TH ROW OF U C 40 IF (K .GT. 1) GO TO 50 DO 41 J = KP1,N 41 A(K,J) = A(K,J)/P GO TO 60 C 50 DO 52 J = KP1,N DSUM = A(K,J) DO 51 L = 1,KM1 51 DSUM = DSUM - DBLE(A(K,L))*DBLE(A(L,J)) A(K,J) = SNGL(DSUM)/P 52 CONTINUE C C COMPUTE THE (K+1)-ST COLUMN OF L C 60 DO 62 I = KP1,N DSUM = A(I,KP1) DO 61 L = 1,K 61 DSUM = DSUM - DBLE(A(I,L))*DBLE(A(L,KP1)) A(I,KP1) = DSUM 62 CONTINUE C KM1 = K 70 CONTINUE C C CHECK THE N-TH PIVOT ELEMENT C D = A(N,N)*D IF (D .EQ. 0.0) RETURN C C SOLVING THE EQUATION LY = B C IF (M .LE. 0) GO TO 120 MAXB = KB*M DO 102 ONEJ = 1,MAXB,KB KJ = ONEJ B(KJ) = B(KJ)/A(1,1) DO 101 K = 2,N KJ = KJ + 1 DSUM = B(KJ) KM1 = K - 1 LJ = ONEJ DO 100 L = 1,KM1 DSUM = DSUM - DBLE(A(K,L))*DBLE(B(LJ)) 100 LJ = LJ + 1 101 B(KJ) = SNGL(DSUM)/A(K,K) 102 CONTINUE C C SOLVING THE EQUATION UX = Y C DO 112 NJ = N,MAXB,KB KJ = NJ DO 111 NMK = 1,NM1 K = N - NMK LJ = KJ KJ = KJ - 1 DSUM = B(KJ) KP1 = K + 1 DO 110 L = KP1,N DSUM = DSUM - DBLE(A(K,L))*DBLE(B(LJ)) 110 LJ = LJ + 1 B(KJ) = DSUM 111 CONTINUE 112 CONTINUE C C REPLACE L WITH THE INVERSE OF L C 120 IF (MO .NE. 0) RETURN DO 132 J = 1,NM1 A(J,J) = 1.0/A(J,J) JP1 = J + 1 DO 131 I = JP1,N DSUM = 0.D0 IM1 = I - 1 DO 130 L = J,IM1 130 DSUM = DSUM + DBLE(A(I,L))*DBLE(A(L,J)) 131 A(I,J) = -SNGL(DSUM)/A(I,I) 132 CONTINUE A(N,N) = 1.0/A(N,N) C C SOLVE UX = Y WHERE Y IS THE INVERSE OF L C DO 152 NMK = 1,NM1 K = N - NMK KP1 = K + 1 DO 140 J = KP1,N TEMP(J) = A(K,J) 140 A(K,J) = 0.0 C DO 151 J = 1,N DSUM = A(K,J) DO 150 L = KP1,N 150 DSUM = DSUM - DBLE(TEMP(L))*DBLE(A(L,J)) A(K,J) = DSUM 151 CONTINUE 152 CONTINUE C C COLUMN INTERCHANGES C DO 161 NMJ = 1,NM1 J = N - NMJ K = INDEX(J) IF (J .EQ. K) GO TO 161 DO 160 I = 1,N T = A(I,J) A(I,J) = A(I,K) 160 A(I,K) = T 161 CONTINUE RETURN C C CASE WHEN N = 1 C 200 D = A(1,1) IF (D .EQ. 0.0) RETURN IF (MO .EQ. 0) A(1,1) = 1.0/D C IF (M .LE. 0) RETURN MAXB = KB*M DO 210 KJ = 1,MAXB,KB 210 B(KJ) = B(KJ)/D RETURN END SUBROUTINE KROUT(MO,N,M,A,KA,B,KB,IERR,INDEX,TEMP) C----------------------------------------------------------------------- C CROUT PROCEDURE FOR INVERTING MATRICES AND SOLVING EQUATIONS C----------------------------------------------------------------------- C A IS A MATRIX OF ORDER N WHERE N IS GREATER THAN OR EQUAL TO 1. C IF MO=0 THEN THE INVERSE OF A IS COMPUTED AND STORED IN A. IF MO C IS NOT 0 THEN THE INVERSE IS NOT COMPUTED. C C IF M IS GREATER THAN 0 THEN B IS A MATRIX HAVING N ROWS AND M C COLUMNS. IN THIS CASE AX=B IS SOLVED AND THE SOLUTION X IS STORED C IN B. IF M=0 THEN THERE ARE NO EQUATIONS TO BE SOLVED. C C KA = THE LENGTH OF THE COLUMNS OF THE ARRAY A C KB = THE LENGTH OF THE COLUMNS OF THE ARRAY B (IF M.GT.0) C C IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS. WHEN C THE ROUTINE TERMINATES IERR HAS ONE OF THE FOLLOWING VALUES ... C IERR = 0 THE REQUESTED TASK WAS PERFORMED. C IERR = -1 EITHER N, KA, OR KB IS INCORRECT. C IERR = K THE K-TH PIVOT ELEMENT IS 0. C C INDEX IS AN ARRAY OF DIMENSION N-1 OR LARGER THAT IS USED BY THE C ROUTINE FOR KEEPING TRACK OF THE ROW INTERCHANGES THAT ARE MADE. C IF MO IS NOT 0 THEN THIS ARRAY IS NOT NEEDED. C C TEMP IS AN ARRAY OF DIMENSION N OR LARGER THAT IS USED WHEN A C IS INVERTED. IF MO IS NOT 0 THEN THIS ARRAY IS NOT NEEDED. C----------------------------------------------------------------------- DIMENSION A(KA,N), B(*), INDEX(*), TEMP(*) INTEGER ONEJ DOUBLE PRECISION DSUM C IF (N .LT. 1 .OR. KA .LT. N) GO TO 320 IF (M .LE. 0) GO TO 5 IF (KB .LT. N) GO TO 320 C 5 IERR = 0 IF (N .LT. 2) GO TO 200 NM1 = N - 1 DO 70 K = 1,NM1 KP1 = K + 1 C C SEARCH FOR THE K-TH PIVOT ELEMENT C P = ABS(A(K,K)) L = K DO 10 I = KP1,N T = ABS(A(I,K)) IF (P .GE. T) GO TO 10 P = T L = I 10 CONTINUE IF (P .EQ. 0.0) GO TO 300 C P = A(L,K) IF (MO .EQ. 0) INDEX(K) = L IF (K .EQ. L) GO TO 40 C C INTERCHANGING ROWS K AND L C DO 20 J = 1,N T = A(K,J) A(K,J) = A(L,J) 20 A(L,J) = T C IF (M .LE. 0) GO TO 40 KJ = K LJ = L DO 30 J = 1,M T = B(KJ) B(KJ) = B(LJ) B(LJ) = T KJ = KJ + KB 30 LJ = LJ + KB C C COMPUTE THE K-TH ROW OF U C 40 IF (K .GT. 1) GO TO 50 DO 41 J = KP1,N 41 A(K,J) = A(K,J)/P GO TO 60 C 50 DO 52 J = KP1,N DSUM = A(K,J) DO 51 L = 1,KM1 51 DSUM = DSUM - DBLE(A(K,L))*DBLE(A(L,J)) A(K,J) = SNGL(DSUM)/P 52 CONTINUE C C COMPUTE THE (K+1)-ST COLUMN OF L C 60 DO 62 I = KP1,N DSUM = A(I,KP1) DO 61 L = 1,K 61 DSUM = DSUM - DBLE(A(I,L))*DBLE(A(L,KP1)) A(I,KP1) = DSUM 62 CONTINUE C KM1 = K 70 CONTINUE C C CHECK THE N-TH PIVOT ELEMENT C IF (A(N,N) .EQ. 0.0) GO TO 310 C C SOLVING THE EQUATION LY = B C IF (M .LE. 0) GO TO 120 MAXB = KB*M DO 102 ONEJ = 1,MAXB,KB KJ = ONEJ B(KJ) = B(KJ)/A(1,1) DO 101 K = 2,N KJ = KJ + 1 DSUM = B(KJ) KM1 = K - 1 LJ = ONEJ DO 100 L = 1,KM1 DSUM = DSUM - DBLE(A(K,L))*DBLE(B(LJ)) 100 LJ = LJ + 1 101 B(KJ) = SNGL(DSUM)/A(K,K) 102 CONTINUE C C SOLVING THE EQUATION UX = Y C DO 112 NJ = N,MAXB,KB KJ = NJ DO 111 NMK = 1,NM1 K = N - NMK LJ = KJ KJ = KJ - 1 DSUM = B(KJ) KP1 = K + 1 DO 110 L = KP1,N DSUM = DSUM - DBLE(A(K,L))*DBLE(B(LJ)) 110 LJ = LJ + 1 B(KJ) = DSUM 111 CONTINUE 112 CONTINUE C C REPLACE L WITH THE INVERSE OF L C 120 IF (MO .NE. 0) RETURN DO 132 J = 1,NM1 A(J,J) = 1.0/A(J,J) JP1 = J + 1 DO 131 I = JP1,N DSUM = 0.D0 IM1 = I - 1 DO 130 L = J,IM1 130 DSUM = DSUM + DBLE(A(I,L))*DBLE(A(L,J)) 131 A(I,J) = -SNGL(DSUM)/A(I,I) 132 CONTINUE A(N,N) = 1.0/A(N,N) C C SOLVE UX = Y WHERE Y IS THE INVERSE OF L C DO 152 NMK = 1,NM1 K = N - NMK KP1 = K + 1 DO 140 J = KP1,N TEMP(J) = A(K,J) 140 A(K,J) = 0.0 C DO 151 J = 1,N DSUM = A(K,J) DO 150 L = KP1,N 150 DSUM = DSUM - DBLE(TEMP(L))*DBLE(A(L,J)) A(K,J) = DSUM 151 CONTINUE 152 CONTINUE C C COLUMN INTERCHANGES C DO 161 NMJ = 1,NM1 J = N - NMJ K = INDEX(J) IF (J .EQ. K) GO TO 161 DO 160 I = 1,N T = A(I,J) A(I,J) = A(I,K) 160 A(I,K) = T 161 CONTINUE RETURN C C CASE WHEN N = 1 C 200 D = A(1,1) IF (D .EQ. 0.0) GO TO 310 IF (MO .EQ. 0) A(1,1) = 1.0/D C IF (M .LE. 0) RETURN MAXB = KB*M DO 210 KJ = 1,MAXB,KB 210 B(KJ) = B(KJ)/D RETURN C C K-TH PIVOT ELEMENT IS 0 C 300 IERR = K RETURN 310 IERR = N RETURN C C INPUT ERROR C 320 IERR = -1 RETURN END SUBROUTINE DEC (N, NDIM, A, IP, IER) C----------------------------------------------------------------------- C MATRIX TRIANGULARIZATION BY GAUSSIAN ELIMINATION. C INPUT.. C N = ORDER OF MATRIX. C NDIM = DECLARED DIMENSION OF ARRAY A . C A = MATRIX TO BE TRIANGULARIZED. C OUTPUT.. C A(I,J), I.LE.J = UPPER TRIANGULAR FACTOR, U . C A(I,J), I.GT.J = MULTIPLIERS = LOWER TRIANGULAR FACTOR, I - L. C IP(K), K.LT.N = INDEX OF K-TH PIVOT ROW. C IP(N) = (-1)**(NUMBER OF INTERCHANGES) OR O . C IER = 0 IF A NONSINGULAR, OR K IF A FOUND TO BE C SINGULAR AT STAGE K. C USE SOL TO OBTAIN SOLUTION OF LINEAR SYSTEM. C DETERM(A) = IP(N)*A(1,1)*A(2,2)*...*A(N,N). C IF IP(N)=0, A IS SINGULAR, SOL WILL DIVIDE BY ZERO. C INTERCHANGES FINISHED IN U , ONLY PARTLY IN L . C C REFERENCE.. C C. B. MOLER, ALGORITHM 423, LINEAR EQUATION SOLVER, C COMM. ASSOC. COMPUT. MACH., 15 (1972), P. 274. C----------------------------------------------------------------------- INTEGER IER, IP, N, NDIM INTEGER I, J, K, KP1, M, NM1 REAL A REAL T DIMENSION A(NDIM,N), IP(N) C IER = 0 IP(N) = 1 IF (N .EQ. 1) GO TO 70 NM1 = N - 1 DO 60 K = 1,NM1 KP1 = K + 1 C FIND THE PIVOT IN COLUMN K. SEARCH ROWS K TO N. -------------------- M = K DO 10 I = KP1,N 10 IF (ABS(A(I,K)) .GT. ABS(A(M,K))) M = I IP(K) = M C INTERCHANGE ELEMENTS IN ROWS K AND M. ------------------------------- T = A(M,K) IF (M .EQ. K) GO TO 20 IP(N) = -IP(N) A(M,K) = A(K,K) A(K,K) = T 20 IF (T .EQ. 0.0) GO TO 80 C STORE MULTIPLIERS IN A(I,K), I = K+1,...,N. ------------------------- T = 1.0/T DO 30 I = KP1,N 30 A(I,K) = -A(I,K)*T C APPLY MULTIPLIERS TO OTHER COLUMNS OF A. ---------------------------- DO 50 J = KP1,N T = A(M,J) A(M,J) = A(K,J) A(K,J) = T IF (T .EQ. 0.0) GO TO 50 DO 40 I = KP1,N 40 A(I,J) = A(I,J) + A(I,K)*T 50 CONTINUE 60 CONTINUE 70 K = N IF (A(N,N) .EQ. 0.0) GO TO 80 RETURN 80 IER = K IP(N) = 0 RETURN END SUBROUTINE SOL (N, NDIM, A, B, IP) C----------------------------------------------------------------------- C SOLUTION OF LINEAR SYSTEM, A*X = B . C INPUT.. C N = ORDER OF MATRIX. C NDIM = DECLARED DIMENSION OF ARRAY A . C A = TRIANGULARIZED MATRIX OBTAINED FROM DEC. C B = RIGHT HAND SIDE VECTOR. C IP = PIVOT VECTOR OBTAINED FROM DEC. C DO NOT USE IF DEC HAS SET IER .NE. 0. C OUTPUT.. C B = SOLUTION VECTOR, X . C----------------------------------------------------------------------- INTEGER IP, N, NDIM INTEGER I, K, KB, KM1, KP1, M, NM1 REAL A, B REAL T DIMENSION A(NDIM, N), B(N), IP(N) C IF (N .EQ. 1) GO TO 50 NM1 = N - 1 C APPLY ROW PERMUTATIONS AND MULTIPLIERS TO B. ------------------------ DO 20 K = 1,NM1 KP1 = K + 1 M = IP(K) T = B(M) B(M) = B(K) B(K) = T DO 10 I = KP1,N 10 B(I) = B(I) + A(I,K)*T 20 CONTINUE C BACK SOLVE. --------------------------------------------------------- DO 40 KB = 1,NM1 KM1 = N - KB K = KM1 + 1 B(K) = B(K)/A(K,K) T = -B(K) DO 30 I = 1,KM1 30 B(I) = B(I) + A(I,K)*T 40 CONTINUE 50 B(1) = B(1)/A(1,1) RETURN END SUBROUTINE NPIVOT (N, M, A, KA, B, KB, D, IERR) C----------------------------------------------------------------------- C MATRIX INVERSION/EQUATION SOLVING WITHOUT PIVOT SEARCH C----------------------------------------------------------------------- REAL A(KA,N), B(*) C IERR = 0 MAXB = KB*M DO 80 K = 1,N C C EXAMINE THE PIVOT ELEMENT C PIVOT = A(K,K) D = D*PIVOT IF (PIVOT .NE. 0.0) GO TO 10 IERR = 1 RETURN C C DIVIDE THE PIVOT ROW BY THE PIVOT ELEMENT C 10 A(K,K) = 1.0 DO 20 L = 1,N A(K,L) = A(K,L)/PIVOT 20 CONTINUE IF (M .LE. 0) GO TO 40 C DO 30 KL = K,MAXB,KB B(KL) = B(KL)/PIVOT 30 CONTINUE C C REDUCE THE NON-PIVOT ROWS C 40 DO 70 J = 1,N IF (J .EQ. K) GO TO 70 T = A(J,K) A(J,K) = 0.0 DO 50 L = 1,N A(J,L) = A(J,L) - A(K,L)*T 50 CONTINUE IF (M .LE. 0) GO TO 70 C KL = K DO 60 JL = J,MAXB,KB B(JL) = B(JL) - B(KL)*T KL = KL + KB 60 CONTINUE 70 CONTINUE C 80 CONTINUE RETURN END SUBROUTINE SLV (N, M, A, KA, B, KB, IERR) REAL A(KA,N), B(KB,M) C ------------------------------------------------------------------ C PARTIAL PIVOT SOLUTION OF A*X = B WHERE A IS A MATRIX OF C ORDER N AND B IS A MATRIX HAVING N ROWS AND M COLUMNS. C THE SOLUTION MATRIX X IS STORED IN B. C C IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS. C IERR = 0 THE EQUATIONS HAVE BEEN SOLVED. C IERR = J THE J-TH PIVOT ELEMENT WAS FOUND TO BE 0. C ------------------------------------------------------------------ IERR = 0 NM1 = N - 1 IF (NM1 .EQ. 0) GO TO 140 DO 80 J = 1,NM1 C C SEARCH FOR THE J-TH PIVOT ELEMENT C P = 0.0 DO 10 I = J,N T = ABS(A(I,J)) IF (T .LE. P) GO TO 10 P = T L = I 10 CONTINUE IF (P .EQ. 0.0) GO TO 210 IF (J .EQ. L) GO TO 40 C C INTERCHANGE ROWS J AND L C DO 20 K = J,N T = A(J,K) A(J,K) = A(L,K) A(L,K) = T 20 CONTINUE DO 30 K = 1,M T = B(J,K) B(J,K) = B(L,K) B(L,K) = T 30 CONTINUE C C ELIMINATE THE COEFFICIENTS OF X(J) IN ROWS I = J+1,...,N C 40 P = A(J,J) JP1 = J + 1 DO 70 I = JP1,N T = A(I,J)/P DO 50 K = JP1,N 50 A(I,K) = A(I,K) - T*A(J,K) DO 60 K = 1,M 60 B(I,K) = B(I,K) - T*B(J,K) 70 CONTINUE 80 CONTINUE IF (A(N,N) .EQ. 0.0) GO TO 220 C C BACKSOLVE THE TRIANGULAR SET OF EQUATIONS C DO 100 J = 1,M 100 B(N,J) = B(N,J)/A(N,N) C DO 130 L = 1,NM1 I = N - L IP1 = I + 1 DO 120 J = 1,M SUM = B(I,J) DO 110 K = IP1,N 110 SUM = SUM - A(I,K)*B(K,J) 120 B(I,J) = SUM/A(I,I) 130 CONTINUE RETURN C C CASE WHEN N = 1 C 140 IF (A(1,1) .EQ. 0.0) GO TO 200 DO 150 J = 1,M 150 B(1,J) = B(1,J)/A(1,1) RETURN C C ERROR RETURN C 200 IERR = 1 RETURN 210 IERR = J RETURN 220 IERR = N RETURN END SUBROUTINE DPSLV (N, M, A, KA, B, KB, IERR) DOUBLE PRECISION A(KA,N), B(KB,M), P, T C ------------------------------------------------------------------ C PARTIAL PIVOT SOLUTION OF A*X = B WHERE A IS A MATRIX OF C ORDER N AND B IS A MATRIX HAVING N ROWS AND M COLUMNS. C THE SOLUTION MATRIX X IS STORED IN B. C C IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS. C IERR = 0 THE EQUATIONS HAVE BEEN SOLVED. C IERR = J THE J-TH PIVOT ELEMENT WAS FOUND TO BE 0. C ------------------------------------------------------------------ IERR = 0 NM1 = N - 1 IF (NM1 .EQ. 0) GO TO 140 DO 80 K = 1,NM1 C C SEARCH FOR THE K-TH PIVOT ELEMENT C P = 0.D0 DO 10 I = K,N T = DABS(A(I,K)) IF (P .GE. T) GO TO 10 P = T L = I 10 CONTINUE IF (P .EQ. 0.D0) GO TO 210 IF (K .EQ. L) GO TO 40 C C INTERCHANGE ROWS K AND L C DO 20 J = K,N T = A(K,J) A(K,J) = A(L,J) A(L,J) = T 20 CONTINUE DO 30 J = 1,M T = B(K,J) B(K,J) = B(L,J) B(L,J) = T 30 CONTINUE C C ELIMINATE THE COEFFICIENTS OF X(K) IN ROWS I = K+1,...,N C 40 P = A(K,K) KP1 = K + 1 DO 70 I = KP1,N T = A(I,K)/P DO 50 J = KP1,N 50 A(I,J) = A(I,J) - T*A(K,J) DO 60 J = 1,M 60 B(I,J) = B(I,J) - T*B(K,J) 70 CONTINUE 80 CONTINUE IF (A(N,N) .EQ. 0.D0) GO TO 220 C C BACKSOLVE THE TRIANGULAR SET OF EQUATIONS C DO 120 J = 1,M K = N KM1 = NM1 DO 110 L = 2,N B(K,J) = B(K,J)/A(K,K) T = B(K,J) DO 100 I = 1,KM1 100 B(I,J) = B(I,J) - T*A(I,K) K = KM1 110 KM1 = K - 1 120 B(1,J) = B(1,J)/A(1,1) RETURN C C CASE WHEN N = 1 C 140 IF (A(1,1) .EQ. 0.D0) GO TO 200 DO 150 J = 1,M 150 B(1,J) = B(1,J)/A(1,1) RETURN C C ERROR RETURN C 200 IERR = 1 RETURN 210 IERR = K RETURN 220 IERR = N RETURN END SUBROUTINE MSLV (MO,N,M,A,KA,B,KB,DET,RCOND,IERR,IPVT,WK) C----------------------------------------------------------------------- C PARTIAL PIVOT GAUSS PROCEDURE FOR INVERTING REAL MATRICES C AND SOLVING REAL EQUATIONS C----------------------------------------------------------------------- REAL A(KA,N), B(*) REAL DET(2), RCOND, T, WK(N) INTEGER IPVT(N), ONEJ C C MATRIX FACTORIZATION AND COMPUTATION OF RCOND C IERR = 0 CALL SGECO (A, KA, N, IPVT, RCOND, WK) T = 1.0 + RCOND IF (T .EQ. 1.0) GO TO 30 C C SOLUTION OF THE EQUATION AX=B C IF (M .LT. 1) GO TO 20 ONEJ = 1 DO 10 J = 1,M CALL SGESL (A, KA, N, IPVT, B(ONEJ), 0) ONEJ = ONEJ + KB 10 CONTINUE C C CALCULATION OF DET AND THE INVERSE OF A C 20 JOB = 10 IF (MO .EQ. 0) JOB = 11 CALL SGEDI (A, KA, N, IPVT, DET, WK, JOB) RETURN C C THE PROBLEM CANNOT BE SOLVED C 30 IERR = 1 RETURN END SUBROUTINE MSLV1 (MO,N,M,A,KA,B,KB,IERR,IPVT,WK) C----------------------------------------------------------------------- C PARTIAL PIVOT GAUSS PROCEDURE FOR INVERTING REAL MATRICES C AND SOLVING REAL EQUATIONS C----------------------------------------------------------------------- REAL A(KA,N), B(*), WK(*) INTEGER IPVT(N) REAL DET(2) INTEGER ONEJ C IF (N .LT. 1 .OR. KA .LT. N) GO TO 40 IF (M .LE. 0) GO TO 10 IF (KB .LT. N) GO TO 40 C C MATRIX FACTORIZATION C 10 CALL SGEFA (A, KA, N, IPVT, IERR) IF (IERR .NE. 0) RETURN C C SOLUTION OF THE EQUATION AX=B C IF (M .LE. 0) GO TO 30 ONEJ = 1 DO 20 J = 1,M CALL SGESL (A, KA, N, IPVT, B(ONEJ), 0) ONEJ = ONEJ + KB 20 CONTINUE C C CALCULATION OF THE INVERSE OF A C 30 IF (MO .EQ. 0) CALL SGEDI (A, KA, N, IPVT, DET, WK, 1) RETURN C C ERROR RETURN C 40 IERR = -1 RETURN END SUBROUTINE SLVMP(MO, N, A, KA, B, X, WK, IWK, IERR) C ****************************************************************** C SOLUTION OF REAL LINEAR EQUATIONS WITH ITERATIVE IMPROVEMENT C ****************************************************************** DIMENSION A(KA,N), B(N), X(N), WK(*), IWK(N) C ------------------- C DIMENSION WK(N*N + N) C ------------------- IF (MO .NE. 0) GO TO 10 C C COMPUTE THE LU DECOMPOSITION OF A C CALL MCOPY(N, N, A, KA, WK, N) CALL SGEFA(WK, N, N, IWK, IERR) IF (IERR .EQ. 0) GO TO 10 IERR = -IERR RETURN C C SOLVE THE SYSTEM OF EQUATIONS AX = B C 10 DO 11 I = 1,N 11 X(I) = B(I) C IR = N*N + 1 CALL SGESL(WK, N, N, IWK, X, 0) CALL LUIMP(A, KA, N, WK(1), N, IWK, B, X, WK(IR), IERR) RETURN END SUBROUTINE LUIMP(A, KA, N, Q, KQ, IPVT, B, X, R, IND) C ---------------------------------------------------------------------- C PURPOSE C GIVEN AN APPROXIMATE SOLUTION X OF A LINEAR SYSTEM AX = B C OBTAINED USING SGECO OR SGEFA. LUIMP ATTEMPTS TO COMPUTE C AN IMPROVED SOLUTION CORRECT TO MACHINE PRECISION. C C PARAMETERS C C A AN ARRAY OF DIMENSION (KA,N) CONTAINING THE MATRIX C A OF ORDER N. C Q AN ARRAY OF DIMENSION (KQ,N) CONTAINING THE LU C DECOMPOSITION OF A PRODUCED BY SGECO OR SGEFA. C IPVT AN ARRAY OF DIMENSION N CONTAINING THE PERMUTATION C INFORMATION GIVEN BY SGECO OR SGEFA. C B THE RIGHT HAND SIDE OF THE EQUATION AX = B. C X ON INPUT X IS THE APPROXIMATE SOLUTION OF AX = B TO C BE IMPROVED. ON OUTPUT X IS THE SOLUTION OBTAINED. C R AN ARRAY FOR INTERNAL USE BY THE ROUTINE. C IND VARIABLE THAT REPORTS THE STATUS OF THE RESULTS. C IND = 0 IF IMPROVEMENT OF X IS SUCCESSFUL WITH A C GAIN IN ACCURACY OF AT LEAST 50 PER CENT EACH C ITERATION. OTHERWISE IND = 1. C C METHOD C LUIMP EXECUTES THE ITERATION CYCLE C (1) AR = B - AX C (2) X = X + R C WITH AN INITIAL GIVEN X. THE RESIDUAL VECTOR B - AX IS C COMPUTED TO HIGH ACCURACY USING DOUBLE PRECISION. SGESL C IS THEN USED TO SOLVE (1). C C ---------------------------------------------------------------------- DIMENSION A(KA,N), Q(KQ,N), IPVT(N), B(N), X(N), R(N) DOUBLE PRECISION DSUM C C ********** EPS IS A MACHINE DEPENDENT PARAMETER. ASSIGN EPS C THE VALUE U WHERE U IS THE SMALLEST FLOATING POINT C NUMBER SUCH THAT 1.0 + U .GT. 1.0. C EPS = SPMPAR(1) C IND = 0 XNRM = 0.0 DO 10 I = 1,N 10 XNRM = XNRM + X(I)*X(I) IF (XNRM .EQ. 0.0) RETURN EPS2 = EPS*EPS RATIO = 1.0 C C COMPUTE THE RESIDUAL VECTOR C 20 DO 22 I = 1,N DSUM = B(I) DO 21 J = 1,N 21 DSUM = DSUM - DBLE(A(I,J))*DBLE(X(J)) 22 R(I) = DSUM C C FIND THE CORRECTION VECTOR C CALL SGESL(Q, KQ, N, IPVT, R, 0) RNRM = 0.0 DO 30 I = 1,N 30 RNRM = RNRM + R(I)*R(I) IF (RNRM .LE. EPS2*XNRM) RETURN C C FORM A NEW APPROXIMATE SOLUTION C DO 40 I = 1,N 40 X(I) = X(I) + R(I) XNRM = 0.0 DO 41 I = 1,N 41 XNRM = XNRM + X(I)*X(I) C IF (XNRM .EQ. 0.0) RETURN RAT = RATIO RATIO = RNRM/XNRM IF (RATIO .LE. 0.25*RAT) GO TO 20 C IF (RATIO .GT. AMIN1(RAT,4.0*EPS2)) IND = 1 RETURN END SUBROUTINE SGECO(A,LDA,N,IPVT,RCOND,Z) INTEGER LDA,N,IPVT(*) REAL A(LDA,*),Z(*) REAL RCOND C C SGECO FACTORS A REAL MATRIX BY GAUSSIAN ELIMINATION C AND ESTIMATES THE CONDITION OF THE MATRIX. C C IF RCOND IS NOT NEEDED, SGEFA IS SLIGHTLY FASTER. C TO SOLVE A*X = B , FOLLOW SGECO BY SGESL. C TO COMPUTE INVERSE(A)*C , FOLLOW SGECO BY SGESL. C TO COMPUTE DETERMINANT(A) , FOLLOW SGECO BY SGEDI. C TO COMPUTE INVERSE(A) , FOLLOW SGECO BY SGEDI. C C ON ENTRY C C A REAL(LDA, N) C THE MATRIX TO BE FACTORED. C C LDA INTEGER C THE LEADING DIMENSION OF THE ARRAY A . C C N INTEGER C THE ORDER OF THE MATRIX A . C C ON RETURN C C A AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS C WHICH WERE USED TO OBTAIN IT. C THE FACTORIZATION CAN BE WRITTEN A = L*U WHERE C L IS A PRODUCT OF PERMUTATION AND UNIT LOWER C TRIANGULAR MATRICES AND U IS UPPER TRIANGULAR. C C IPVT INTEGER(N) C AN INTEGER VECTOR OF PIVOT INDICES. C C RCOND REAL C AN ESTIMATE OF THE RECIPROCAL CONDITION OF A . C FOR THE SYSTEM A*X = B , RELATIVE PERTURBATIONS C IN A AND B OF SIZE EPSILON MAY CAUSE C RELATIVE PERTURBATIONS IN X OF SIZE EPSILON/RCOND . C IF RCOND IS SO SMALL THAT THE LOGICAL EXPRESSION C 1.0 + RCOND .EQ. 1.0 C IS TRUE, THEN A MAY BE SINGULAR TO WORKING C PRECISION. IN PARTICULAR, RCOND IS ZERO IF C EXACT SINGULARITY IS DETECTED OR THE ESTIMATE C UNDERFLOWS. C C Z REAL(N) C A WORK VECTOR WHOSE CONTENTS ARE USUALLY UNIMPORTANT. C IF A IS CLOSE TO A SINGULAR MATRIX, THEN Z IS C AN APPROXIMATE NULL VECTOR IN THE SENSE THAT C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . C C LINPACK. THIS VERSION DATED 08/14/78 . C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. C C SUBROUTINES AND FUNCTIONS C C LINPACK SGEFA C BLAS SAXPY,SDOT,SSCAL,SASUM C FORTRAN ABS,AMAX1,SIGN C C INTERNAL VARIABLES C REAL SDOT,EK,T,WK,WKM REAL ANORM,S,SASUM,SM,YNORM INTEGER INFO,J,K,KB,KP1,L C C C COMPUTE 1-NORM OF A C ANORM = 0.0E0 DO 10 J = 1, N ANORM = AMAX1(ANORM,SASUM(N,A(1,J),1)) 10 CONTINUE C C FACTOR C CALL SGEFA(A,LDA,N,IPVT,INFO) C C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND TRANS(A)*Y = E . C TRANS(A) IS THE TRANSPOSE OF A . THE COMPONENTS OF E ARE C CHOSEN TO CAUSE MAXIMUM LOCAL GROWTH IN THE ELEMENTS OF W WHERE C TRANS(U)*W = E . THE VECTORS ARE FREQUENTLY RESCALED TO AVOID C OVERFLOW. C C SOLVE TRANS(U)*W = E C EK = 1.0E0 DO 20 J = 1, N Z(J) = 0.0E0 20 CONTINUE DO 100 K = 1, N IF (Z(K) .NE. 0.0E0) EK = SIGN(EK,-Z(K)) IF (ABS(EK-Z(K)) .LE. ABS(A(K,K))) GO TO 30 S = ABS(A(K,K))/ABS(EK-Z(K)) CALL SSCAL(N,S,Z,1) EK = S*EK 30 CONTINUE WK = EK - Z(K) WKM = -EK - Z(K) S = ABS(WK) SM = ABS(WKM) IF (A(K,K) .EQ. 0.0E0) GO TO 40 WK = WK/A(K,K) WKM = WKM/A(K,K) GO TO 50 40 CONTINUE WK = 1.0E0 WKM = 1.0E0 50 CONTINUE KP1 = K + 1 IF (KP1 .GT. N) GO TO 90 DO 60 J = KP1, N SM = SM + ABS(Z(J)+WKM*A(K,J)) Z(J) = Z(J) + WK*A(K,J) S = S + ABS(Z(J)) 60 CONTINUE IF (S .GE. SM) GO TO 80 T = WKM - WK WK = WKM DO 70 J = KP1, N Z(J) = Z(J) + T*A(K,J) 70 CONTINUE 80 CONTINUE 90 CONTINUE Z(K) = WK 100 CONTINUE S = 1.0E0/SASUM(N,Z,1) CALL SSCAL(N,S,Z,1) C C SOLVE TRANS(L)*Y = W C DO 120 KB = 1, N K = N + 1 - KB IF (K .LT. N) Z(K) = Z(K) + SDOT(N-K,A(K+1,K),1,Z(K+1),1) IF (ABS(Z(K)) .LE. 1.0E0) GO TO 110 S = 1.0E0/ABS(Z(K)) CALL SSCAL(N,S,Z,1) 110 CONTINUE L = IPVT(K) T = Z(L) Z(L) = Z(K) Z(K) = T 120 CONTINUE S = 1.0E0/SASUM(N,Z,1) CALL SSCAL(N,S,Z,1) C YNORM = 1.0E0 C C SOLVE L*V = Y C DO 140 K = 1, N L = IPVT(K) T = Z(L) Z(L) = Z(K) Z(K) = T IF (K .LT. N) CALL SAXPY(N-K,T,A(K+1,K),1,Z(K+1),1) IF (ABS(Z(K)) .LE. 1.0E0) GO TO 130 S = 1.0E0/ABS(Z(K)) CALL SSCAL(N,S,Z,1) YNORM = S*YNORM 130 CONTINUE 140 CONTINUE S = 1.0E0/SASUM(N,Z,1) CALL SSCAL(N,S,Z,1) YNORM = S*YNORM C C SOLVE U*Z = V C DO 160 KB = 1, N K = N + 1 - KB IF (ABS(Z(K)) .LE. ABS(A(K,K))) GO TO 150 S = ABS(A(K,K))/ABS(Z(K)) CALL SSCAL(N,S,Z,1) YNORM = S*YNORM 150 CONTINUE IF (A(K,K) .NE. 0.0E0) Z(K) = Z(K)/A(K,K) IF (A(K,K) .EQ. 0.0E0) Z(K) = 1.0E0 T = -Z(K) CALL SAXPY(K-1,T,A(1,K),1,Z(1),1) 160 CONTINUE C MAKE ZNORM = 1.0 S = 1.0E0/SASUM(N,Z,1) CALL SSCAL(N,S,Z,1) YNORM = S*YNORM C IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0 RETURN END SUBROUTINE SGEFA(A,LDA,N,IPVT,INFO) INTEGER LDA,N,IPVT(*),INFO REAL A(LDA,*) C C SGEFA FACTORS A REAL MATRIX BY GAUSSIAN ELIMINATION. C C SGEFA IS USUALLY CALLED BY SGECO, BUT IT CAN BE CALLED C DIRECTLY WITH A SAVING IN TIME IF RCOND IS NOT NEEDED. C (TIME FOR SGECO) = (1 + 9/N)*(TIME FOR SGEFA) . C C ON ENTRY C C A REAL(LDA, N) C THE MATRIX TO BE FACTORED. C C LDA INTEGER C THE LEADING DIMENSION OF THE ARRAY A . C C N INTEGER C THE ORDER OF THE MATRIX A . C C ON RETURN C C A AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS C WHICH WERE USED TO OBTAIN IT. C THE FACTORIZATION CAN BE WRITTEN A = L*U WHERE C L IS A PRODUCT OF PERMUTATION AND UNIT LOWER C TRIANGULAR MATRICES AND U IS UPPER TRIANGULAR. C C IPVT INTEGER(N) C AN INTEGER VECTOR OF PIVOT INDICES. C C INFO INTEGER C = 0 NORMAL VALUE. C = K IF U(K,K) .EQ. 0.0 . THIS IS NOT AN ERROR C CONDITION FOR THIS SUBROUTINE, BUT IT DOES C INDICATE THAT SGESL OR SGEDI WILL DIVIDE BY ZERO C IF CALLED. USE RCOND IN SGECO FOR A RELIABLE C INDICATION OF SINGULARITY. C C LINPACK. THIS VERSION DATED 08/14/78 . C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. C C SUBROUTINES AND FUNCTIONS C C BLAS SAXPY,SSCAL,ISAMAX C C INTERNAL VARIABLES C REAL T INTEGER ISAMAX,J,K,KP1,L,NM1 C C C GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING C INFO = 0 NM1 = N - 1 IF (NM1 .LT. 1) GO TO 70 DO 60 K = 1, NM1 KP1 = K + 1 C C FIND L = PIVOT INDEX C L = ISAMAX(N-K+1,A(K,K),1) + K - 1 IPVT(K) = L C C ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED C IF (A(L,K) .EQ. 0.0E0) GO TO 40 C C INTERCHANGE IF NECESSARY C IF (L .EQ. K) GO TO 10 T = A(L,K) A(L,K) = A(K,K) A(K,K) = T 10 CONTINUE C C COMPUTE MULTIPLIERS C T = -1.0E0/A(K,K) CALL SSCAL(N-K,T,A(K+1,K),1) C C ROW ELIMINATION WITH COLUMN INDEXING C DO 30 J = KP1, N T = A(L,J) IF (L .EQ. K) GO TO 20 A(L,J) = A(K,J) A(K,J) = T 20 CONTINUE CALL SAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1) 30 CONTINUE GO TO 50 40 CONTINUE INFO = K 50 CONTINUE 60 CONTINUE 70 CONTINUE IPVT(N) = N IF (A(N,N) .EQ. 0.0E0) INFO = N RETURN END SUBROUTINE SGESL(A,LDA,N,IPVT,B,JOB) INTEGER LDA,N,IPVT(*),JOB REAL A(LDA,*),B(*) C C SGESL SOLVES THE REAL SYSTEM C A * X = B OR TRANS(A) * X = B C USING THE FACTORS COMPUTED BY SGECO OR SGEFA. C C ON ENTRY C C A REAL(LDA, N) C THE OUTPUT FROM SGECO OR SGEFA. C C LDA INTEGER C THE LEADING DIMENSION OF THE ARRAY A . C C N INTEGER C THE ORDER OF THE MATRIX A . C C IPVT INTEGER(N) C THE PIVOT VECTOR FROM SGECO OR SGEFA. C C B REAL(N) C THE RIGHT HAND SIDE VECTOR. C C JOB INTEGER C = 0 TO SOLVE A*X = B , C = NONZERO TO SOLVE TRANS(A)*X = B WHERE C TRANS(A) IS THE TRANSPOSE. C C ON RETURN C C B THE SOLUTION VECTOR X . C C ERROR CONDITION C C A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A C ZERO ON THE DIAGONAL. TECHNICALLY THIS INDICATES SINGULARITY C BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER C SETTING OF LDA . IT WILL NOT OCCUR IF THE SUBROUTINES ARE C CALLED CORRECTLY AND IF SGECO HAS SET RCOND .GT. 0.0 C OR SGEFA HAS SET INFO .EQ. 0 . C C TO COMPUTE INVERSE(A) * C WHERE C IS A MATRIX C WITH P COLUMNS C CALL SGECO(A,LDA,N,IPVT,RCOND,Z) C IF (RCOND IS TOO SMALL) GO TO ... C DO 10 J = 1, P C CALL SGESL(A,LDA,N,IPVT,C(1,J),0) C 10 CONTINUE C C LINPACK. THIS VERSION DATED 08/14/78 . C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. C C SUBROUTINES AND FUNCTIONS C C BLAS SAXPY,SDOT C C INTERNAL VARIABLES C REAL SDOT,T INTEGER K,KB,L,NM1 C NM1 = N - 1 IF (JOB .NE. 0) GO TO 50 C C JOB = 0 , SOLVE A * X = B C FIRST SOLVE L*Y = B C IF (NM1 .LT. 1) GO TO 30 DO 20 K = 1, NM1 L = IPVT(K) T = B(L) IF (L .EQ. K) GO TO 10 B(L) = B(K) B(K) = T 10 CONTINUE CALL SAXPY(N-K,T,A(K+1,K),1,B(K+1),1) 20 CONTINUE 30 CONTINUE C C NOW SOLVE U*X = Y C DO 40 KB = 1, N K = N + 1 - KB B(K) = B(K)/A(K,K) T = -B(K) CALL SAXPY(K-1,T,A(1,K),1,B(1),1) 40 CONTINUE GO TO 100 50 CONTINUE C C JOB = NONZERO, SOLVE TRANS(A) * X = B C FIRST SOLVE TRANS(U)*Y = B C DO 60 K = 1, N T = SDOT(K-1,A(1,K),1,B(1),1) B(K) = (B(K) - T)/A(K,K) 60 CONTINUE C C NOW SOLVE TRANS(L)*X = Y C IF (NM1 .LT. 1) GO TO 90 DO 80 KB = 1, NM1 K = N - KB B(K) = B(K) + SDOT(N-K,A(K+1,K),1,B(K+1),1) L = IPVT(K) IF (L .EQ. K) GO TO 70 T = B(L) B(L) = B(K) B(K) = T 70 CONTINUE 80 CONTINUE 90 CONTINUE 100 CONTINUE RETURN END SUBROUTINE SGEDI(A,LDA,N,IPVT,DET,WORK,JOB) INTEGER LDA,N,IPVT(*),JOB REAL A(LDA,*),DET(2),WORK(*) C C SGEDI COMPUTES THE DETERMINANT AND INVERSE OF A MATRIX C USING THE FACTORS COMPUTED BY SGECO OR SGEFA. C C ON ENTRY C C A REAL(LDA, N) C THE OUTPUT FROM SGECO OR SGEFA. C C LDA INTEGER C THE LEADING DIMENSION OF THE ARRAY A . C C N INTEGER C THE ORDER OF THE MATRIX A . C C IPVT INTEGER(N) C THE PIVOT VECTOR FROM SGECO OR SGEFA. C C WORK REAL(N) C WORK VECTOR. CONTENTS DESTROYED. C C JOB INTEGER C = 11 BOTH DETERMINANT AND INVERSE. C = 01 INVERSE ONLY. C = 10 DETERMINANT ONLY. C C ON RETURN C C A INVERSE OF ORIGINAL MATRIX IF REQUESTED. C OTHERWISE UNCHANGED. C C DET REAL(2) C DETERMINANT OF ORIGINAL MATRIX IF REQUESTED. C OTHERWISE NOT REFERENCED. C DETERMINANT = DET(1) * 10.0**DET(2) C WITH 1.0 .LE. ABS(DET(1)) .LT. 10.0 C OR DET(1) .EQ. 0.0 . C C ERROR CONDITION C C A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS C A ZERO ON THE DIAGONAL AND THE INVERSE IS REQUESTED. C IT WILL NOT OCCUR IF THE SUBROUTINES ARE CALLED CORRECTLY C AND IF SGECO HAS SET RCOND .GT. 0.0 OR SGEFA HAS SET C INFO .EQ. 0 . C C LINPACK. THIS VERSION DATED 08/14/78 . C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. C C SUBROUTINES AND FUNCTIONS C C BLAS SAXPY,SSCAL,SSWAP C FORTRAN ABS,MOD C C INTERNAL VARIABLES C REAL T REAL TEN INTEGER I,J,K,KB,KP1,L,NM1 C C C COMPUTE DETERMINANT C IF (JOB/10 .EQ. 0) GO TO 70 DET(1) = 1.0E0 DET(2) = 0.0E0 TEN = 10.0E0 DO 50 I = 1, N IF (IPVT(I) .NE. I) DET(1) = -DET(1) DET(1) = A(I,I)*DET(1) C ...EXIT IF (DET(1) .EQ. 0.0E0) GO TO 60 10 IF (ABS(DET(1)) .GE. 1.0E0) GO TO 20 DET(1) = TEN*DET(1) DET(2) = DET(2) - 1.0E0 GO TO 10 20 CONTINUE 30 IF (ABS(DET(1)) .LT. TEN) GO TO 40 DET(1) = DET(1)/TEN DET(2) = DET(2) + 1.0E0 GO TO 30 40 CONTINUE 50 CONTINUE 60 CONTINUE 70 CONTINUE C C COMPUTE INVERSE(U) C IF (MOD(JOB,10) .EQ. 0) GO TO 150 DO 100 K = 1, N A(K,K) = 1.0E0/A(K,K) T = -A(K,K) CALL SSCAL(K-1,T,A(1,K),1) KP1 = K + 1 IF (N .LT. KP1) GO TO 90 DO 80 J = KP1, N T = A(K,J) A(K,J) = 0.0E0 CALL SAXPY(K,T,A(1,K),1,A(1,J),1) 80 CONTINUE 90 CONTINUE 100 CONTINUE C C FORM INVERSE(U)*INVERSE(L) C NM1 = N - 1 IF (NM1 .LT. 1) GO TO 140 DO 130 KB = 1, NM1 K = N - KB KP1 = K + 1 DO 110 I = KP1, N WORK(I) = A(I,K) A(I,K) = 0.0E0 110 CONTINUE DO 120 J = KP1, N T = WORK(J) CALL SAXPY(N,T,A(1,J),1,A(1,K),1) 120 CONTINUE L = IPVT(K) IF (L .NE. K) CALL SSWAP(N,A(1,K),1,A(1,L),1) 130 CONTINUE 140 CONTINUE 150 CONTINUE RETURN END SUBROUTINE DMSLV (MO,N,M,A,KA,B,KB,DET,RCOND,IERR,IPVT,WK) C----------------------------------------------------------------------- C PARTIAL PIVOT GAUSS PROCEDURE FOR INVERTING DOUBLE PRECISION C REAL MATRICES AND SOLVING DOUBLE PRECISION REAL EQUATIONS C----------------------------------------------------------------------- DOUBLE PRECISION A(KA,N), B(*) DOUBLE PRECISION DET(2), RCOND, T, WK(N) INTEGER IPVT(N), ONEJ C C MATRIX FACTORIZATION AND COMPUTATION OF RCOND C IERR = 0 CALL DGECO (A, KA, N, IPVT, RCOND, WK) T = 1.D0 + RCOND IF (T .EQ. 1.D0) GO TO 30 C C SOLUTION OF THE EQUATION AX=B C IF (M .LT. 1) GO TO 20 ONEJ = 1 DO 10 J = 1,M CALL DGESL (A, KA, N, IPVT, B(ONEJ), 0) ONEJ = ONEJ + KB 10 CONTINUE C C CALCULATION OF DET AND THE INVERSE OF A C 20 JOB = 10 IF (MO .EQ. 0) JOB = 11 CALL DGEDI (A, KA, N, IPVT, DET, WK, JOB) RETURN C C THE PROBLEM CANNOT BE SOLVED C 30 IERR = 1 RETURN END SUBROUTINE DMSLV1 (MO,N,M,A,KA,B,KB,IERR,IPVT,WK) C----------------------------------------------------------------------- C PARTIAL PIVOT GAUSS PROCEDURE FOR INVERTING DOUBLE PRECISION C REAL MATRICES AND SOLVING DOUBLE PRECISION REAL EQUATIONS C----------------------------------------------------------------------- DOUBLE PRECISION A(KA,N), B(*), WK(*) INTEGER IPVT(N) DOUBLE PRECISION DET(2) INTEGER ONEJ C IF (N .LT. 1 .OR. KA .LT. N) GO TO 40 IF (M .LE. 0) GO TO 10 IF (KB .LT. N) GO TO 40 C C MATRIX FACTORIZATION C 10 CALL DGEFA (A, KA, N, IPVT, IERR) IF (IERR .NE. 0) RETURN C C SOLUTION OF THE EQUATION AX=B C IF (M .LE. 0) GO TO 30 ONEJ = 1 DO 20 J = 1,M CALL DGESL (A, KA, N, IPVT, B(ONEJ), 0) ONEJ = ONEJ + KB 20 CONTINUE C C CALCULATION OF THE INVERSE OF A C 30 IF (MO .EQ. 0) CALL DGEDI (A, KA, N, IPVT, DET, WK, 1) RETURN C C ERROR RETURN C 40 IERR = -1 RETURN END SUBROUTINE DGECO(A,LDA,N,IPVT,RCOND,Z) INTEGER LDA,N,IPVT(*) DOUBLE PRECISION A(LDA,*),Z(*) DOUBLE PRECISION RCOND C C DGECO FACTORS A DOUBLE PRECISION MATRIX BY GAUSSIAN ELIMINATION C AND ESTIMATES THE CONDITION OF THE MATRIX. C C IF RCOND IS NOT NEEDED, DGEFA IS SLIGHTLY FASTER. C TO SOLVE A*X = B , FOLLOW DGECO BY DGESL. C TO COMPUTE INVERSE(A)*C , FOLLOW DGECO BY DGESL. C TO COMPUTE DETERMINANT(A) , FOLLOW DGECO BY DGEDI. C TO COMPUTE INVERSE(A) , FOLLOW DGECO BY DGEDI. C C ON ENTRY C C A DOUBLE PRECISION(LDA, N) C THE MATRIX TO BE FACTORED. C C LDA INTEGER C THE LEADING DIMENSION OF THE ARRAY A . C C N INTEGER C THE ORDER OF THE MATRIX A . C C ON RETURN C C A AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS C WHICH WERE USED TO OBTAIN IT. C THE FACTORIZATION CAN BE WRITTEN A = L*U WHERE C L IS A PRODUCT OF PERMUTATION AND UNIT LOWER C TRIANGULAR MATRICES AND U IS UPPER TRIANGULAR. C C IPVT INTEGER(N) C AN INTEGER VECTOR OF PIVOT INDICES. C C RCOND DOUBLE PRECISION C AN ESTIMATE OF THE RECIPROCAL CONDITION OF A . C FOR THE SYSTEM A*X = B , RELATIVE PERTURBATIONS C IN A AND B OF SIZE EPSILON MAY CAUSE C RELATIVE PERTURBATIONS IN X OF SIZE EPSILON/RCOND . C IF RCOND IS SO SMALL THAT THE LOGICAL EXPRESSION C 1.0 + RCOND .EQ. 1.0 C IS TRUE, THEN A MAY BE SINGULAR TO WORKING C PRECISION. IN PARTICULAR, RCOND IS ZERO IF C EXACT SINGULARITY IS DETECTED OR THE ESTIMATE C UNDERFLOWS. C C Z DOUBLE PRECISION(N) C A WORK VECTOR WHOSE CONTENTS ARE USUALLY UNIMPORTANT. C IF A IS CLOSE TO A SINGULAR MATRIX, THEN Z IS C AN APPROXIMATE NULL VECTOR IN THE SENSE THAT C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . C C LINPACK. THIS VERSION DATED 08/14/78 . C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. C C SUBROUTINES AND FUNCTIONS C C LINPACK DGEFA C BLAS DAXPY,DDOT,DSCAL,DASUM C FORTRAN DABS,DMAX1,DSIGN C C INTERNAL VARIABLES C DOUBLE PRECISION DDOT,EK,T,WK,WKM DOUBLE PRECISION ANORM,S,DASUM,SM,YNORM INTEGER INFO,J,K,KB,KP1,L C C C COMPUTE 1-NORM OF A C ANORM = 0.0D0 DO 10 J = 1, N ANORM = DMAX1(ANORM,DASUM(N,A(1,J),1)) 10 CONTINUE C C FACTOR C CALL DGEFA(A,LDA,N,IPVT,INFO) C C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND TRANS(A)*Y = E . C TRANS(A) IS THE TRANSPOSE OF A . THE COMPONENTS OF E ARE C CHOSEN TO CAUSE MAXIMUM LOCAL GROWTH IN THE ELEMENTS OF W WHERE C TRANS(U)*W = E . THE VECTORS ARE FREQUENTLY RESCALED TO AVOID C OVERFLOW. C C SOLVE TRANS(U)*W = E C EK = 1.0D0 DO 20 J = 1, N Z(J) = 0.0D0 20 CONTINUE DO 100 K = 1, N IF (Z(K) .NE. 0.0D0) EK = DSIGN(EK,-Z(K)) IF (DABS(EK-Z(K)) .LE. DABS(A(K,K))) GO TO 30 S = DABS(A(K,K))/DABS(EK-Z(K)) CALL DSCAL(N,S,Z,1) EK = S*EK 30 CONTINUE WK = EK - Z(K) WKM = -EK - Z(K) S = DABS(WK) SM = DABS(WKM) IF (A(K,K) .EQ. 0.0D0) GO TO 40 WK = WK/A(K,K) WKM = WKM/A(K,K) GO TO 50 40 CONTINUE WK = 1.0D0 WKM = 1.0D0 50 CONTINUE KP1 = K + 1 IF (KP1 .GT. N) GO TO 90 DO 60 J = KP1, N SM = SM + DABS(Z(J)+WKM*A(K,J)) Z(J) = Z(J) + WK*A(K,J) S = S + DABS(Z(J)) 60 CONTINUE IF (S .GE. SM) GO TO 80 T = WKM - WK WK = WKM DO 70 J = KP1, N Z(J) = Z(J) + T*A(K,J) 70 CONTINUE 80 CONTINUE 90 CONTINUE Z(K) = WK 100 CONTINUE S = 1.0D0/DASUM(N,Z,1) CALL DSCAL(N,S,Z,1) C C SOLVE TRANS(L)*Y = W C DO 120 KB = 1, N K = N + 1 - KB IF (K .LT. N) Z(K) = Z(K) + DDOT(N-K,A(K+1,K),1,Z(K+1),1) IF (DABS(Z(K)) .LE. 1.0D0) GO TO 110 S = 1.0D0/DABS(Z(K)) CALL DSCAL(N,S,Z,1) 110 CONTINUE L = IPVT(K) T = Z(L) Z(L) = Z(K) Z(K) = T 120 CONTINUE S = 1.0D0/DASUM(N,Z,1) CALL DSCAL(N,S,Z,1) C YNORM = 1.0D0 C C SOLVE L*V = Y C DO 140 K = 1, N L = IPVT(K) T = Z(L) Z(L) = Z(K) Z(K) = T IF (K .LT. N) CALL DAXPY(N-K,T,A(K+1,K),1,Z(K+1),1) IF (DABS(Z(K)) .LE. 1.0D0) GO TO 130 S = 1.0D0/DABS(Z(K)) CALL DSCAL(N,S,Z,1) YNORM = S*YNORM 130 CONTINUE 140 CONTINUE S = 1.0D0/DASUM(N,Z,1) CALL DSCAL(N,S,Z,1) YNORM = S*YNORM C C SOLVE U*Z = V C DO 160 KB = 1, N K = N + 1 - KB IF (DABS(Z(K)) .LE. DABS(A(K,K))) GO TO 150 S = DABS(A(K,K))/DABS(Z(K)) CALL DSCAL(N,S,Z,1) YNORM = S*YNORM 150 CONTINUE IF (A(K,K) .NE. 0.0D0) Z(K) = Z(K)/A(K,K) IF (A(K,K) .EQ. 0.0D0) Z(K) = 1.0D0 T = -Z(K) CALL DAXPY(K-1,T,A(1,K),1,Z(1),1) 160 CONTINUE C MAKE ZNORM = 1.0 S = 1.0D0/DASUM(N,Z,1) CALL DSCAL(N,S,Z,1) YNORM = S*YNORM C IF (ANORM .NE. 0.0D0) RCOND = YNORM/ANORM IF (ANORM .EQ. 0.0D0) RCOND = 0.0D0 RETURN END SUBROUTINE DGEFA(A,LDA,N,IPVT,INFO) INTEGER LDA,N,IPVT(*),INFO DOUBLE PRECISION A(LDA,*) C C DGEFA FACTORS A DOUBLE PRECISION MATRIX BY GAUSSIAN ELIMINATION. C C DGEFA IS USUALLY CALLED BY DGECO, BUT IT CAN BE CALLED C DIRECTLY WITH A SAVING IN TIME IF RCOND IS NOT NEEDED. C (TIME FOR DGECO) = (1 + 9/N)*(TIME FOR DGEFA) . C C ON ENTRY C C A DOUBLE PRECISION(LDA, N) C THE MATRIX TO BE FACTORED. C C LDA INTEGER C THE LEADING DIMENSION OF THE ARRAY A . C C N INTEGER C THE ORDER OF THE MATRIX A . C C ON RETURN C C A AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS C WHICH WERE USED TO OBTAIN IT. C THE FACTORIZATION CAN BE WRITTEN A = L*U WHERE C L IS A PRODUCT OF PERMUTATION AND UNIT LOWER C TRIANGULAR MATRICES AND U IS UPPER TRIANGULAR. C C IPVT INTEGER(N) C AN INTEGER VECTOR OF PIVOT INDICES. C C INFO INTEGER C = 0 NORMAL VALUE. C = K IF U(K,K) .EQ. 0.0 . THIS IS NOT AN ERROR C CONDITION FOR THIS SUBROUTINE, BUT IT DOES C INDICATE THAT DGESL OR DGEDI WILL DIVIDE BY ZERO C IF CALLED. USE RCOND IN DGECO FOR A RELIABLE C INDICATION OF SINGULARITY. C C LINPACK. THIS VERSION DATED 08/14/78 . C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. C C SUBROUTINES AND FUNCTIONS C C BLAS DAXPY,DSCAL,IDAMAX C C INTERNAL VARIABLES C DOUBLE PRECISION T INTEGER IDAMAX,J,K,KP1,L,NM1 C C C GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING C INFO = 0 NM1 = N - 1 IF (NM1 .LT. 1) GO TO 70 DO 60 K = 1, NM1 KP1 = K + 1 C C FIND L = PIVOT INDEX C L = IDAMAX(N-K+1,A(K,K),1) + K - 1 IPVT(K) = L C C ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED C IF (A(L,K) .EQ. 0.0D0) GO TO 40 C C INTERCHANGE IF NECESSARY C IF (L .EQ. K) GO TO 10 T = A(L,K) A(L,K) = A(K,K) A(K,K) = T 10 CONTINUE C C COMPUTE MULTIPLIERS C T = -1.0D0/A(K,K) CALL DSCAL(N-K,T,A(K+1,K),1) C C ROW ELIMINATION WITH COLUMN INDEXING C DO 30 J = KP1, N T = A(L,J) IF (L .EQ. K) GO TO 20 A(L,J) = A(K,J) A(K,J) = T 20 CONTINUE CALL DAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1) 30 CONTINUE GO TO 50 40 CONTINUE INFO = K 50 CONTINUE 60 CONTINUE 70 CONTINUE IPVT(N) = N IF (A(N,N) .EQ. 0.0D0) INFO = N RETURN END SUBROUTINE DGESL(A,LDA,N,IPVT,B,JOB) INTEGER LDA,N,IPVT(*),JOB DOUBLE PRECISION A(LDA,*),B(*) C C DGESL SOLVES THE DOUBLE PRECISION SYSTEM C A * X = B OR TRANS(A) * X = B C USING THE FACTORS COMPUTED BY DGECO OR DGEFA. C C ON ENTRY C C A DOUBLE PRECISION(LDA, N) C THE OUTPUT FROM DGECO OR DGEFA. C C LDA INTEGER C THE LEADING DIMENSION OF THE ARRAY A . C C N INTEGER C THE ORDER OF THE MATRIX A . C C IPVT INTEGER(N) C THE PIVOT VECTOR FROM DGECO OR DGEFA. C C B DOUBLE PRECISION(N) C THE RIGHT HAND SIDE VECTOR. C C JOB INTEGER C = 0 TO SOLVE A*X = B , C = NONZERO TO SOLVE TRANS(A)*X = B WHERE C TRANS(A) IS THE TRANSPOSE. C C ON RETURN C C B THE SOLUTION VECTOR X . C C ERROR CONDITION C C A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A C ZERO ON THE DIAGONAL. TECHNICALLY THIS INDICATES SINGULARITY C BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER C SETTING OF LDA . IT WILL NOT OCCUR IF THE SUBROUTINES ARE C CALLED CORRECTLY AND IF DGECO HAS SET RCOND .GT. 0.0 C OR DGEFA HAS SET INFO .EQ. 0 . C C TO COMPUTE INVERSE(A) * C WHERE C IS A MATRIX C WITH P COLUMNS C CALL DGECO(A,LDA,N,IPVT,RCOND,Z) C IF (RCOND IS TOO SMALL) GO TO ... C DO 10 J = 1, P C CALL DGESL(A,LDA,N,IPVT,C(1,J),0) C 10 CONTINUE C C LINPACK. THIS VERSION DATED 08/14/78 . C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. C C SUBROUTINES AND FUNCTIONS C C BLAS DAXPY,DDOT C C INTERNAL VARIABLES C DOUBLE PRECISION DDOT,T INTEGER K,KB,L,NM1 C NM1 = N - 1 IF (JOB .NE. 0) GO TO 50 C C JOB = 0 , SOLVE A * X = B C FIRST SOLVE L*Y = B C IF (NM1 .LT. 1) GO TO 30 DO 20 K = 1, NM1 L = IPVT(K) T = B(L) IF (L .EQ. K) GO TO 10 B(L) = B(K) B(K) = T 10 CONTINUE CALL DAXPY(N-K,T,A(K+1,K),1,B(K+1),1) 20 CONTINUE 30 CONTINUE C C NOW SOLVE U*X = Y C DO 40 KB = 1, N K = N + 1 - KB B(K) = B(K)/A(K,K) T = -B(K) CALL DAXPY(K-1,T,A(1,K),1,B(1),1) 40 CONTINUE GO TO 100 50 CONTINUE C C JOB = NONZERO, SOLVE TRANS(A) * X = B C FIRST SOLVE TRANS(U)*Y = B C DO 60 K = 1, N T = DDOT(K-1,A(1,K),1,B(1),1) B(K) = (B(K) - T)/A(K,K) 60 CONTINUE C C NOW SOLVE TRANS(L)*X = Y C IF (NM1 .LT. 1) GO TO 90 DO 80 KB = 1, NM1 K = N - KB B(K) = B(K) + DDOT(N-K,A(K+1,K),1,B(K+1),1) L = IPVT(K) IF (L .EQ. K) GO TO 70 T = B(L) B(L) = B(K) B(K) = T 70 CONTINUE 80 CONTINUE 90 CONTINUE 100 CONTINUE RETURN END SUBROUTINE DGEDI(A,LDA,N,IPVT,DET,WORK,JOB) INTEGER LDA,N,IPVT(*),JOB DOUBLE PRECISION A(LDA,*),DET(2),WORK(*) C C DGEDI COMPUTES THE DETERMINANT AND INVERSE OF A MATRIX C USING THE FACTORS COMPUTED BY DGECO OR DGEFA. C C ON ENTRY C C A DOUBLE PRECISION(LDA, N) C THE OUTPUT FROM DGECO OR DGEFA. C C LDA INTEGER C THE LEADING DIMENSION OF THE ARRAY A . C C N INTEGER C THE ORDER OF THE MATRIX A . C C IPVT INTEGER(N) C THE PIVOT VECTOR FROM DGECO OR DGEFA. C C WORK DOUBLE PRECISION(N) C WORK VECTOR. CONTENTS DESTROYED. C C JOB INTEGER C = 11 BOTH DETERMINANT AND INVERSE. C = 01 INVERSE ONLY. C = 10 DETERMINANT ONLY. C C ON RETURN C C A INVERSE OF ORIGINAL MATRIX IF REQUESTED. C OTHERWISE UNCHANGED. C C DET DOUBLE PRECISION(2) C DETERMINANT OF ORIGINAL MATRIX IF REQUESTED. C OTHERWISE NOT REFERENCED. C DETERMINANT = DET(1) * 10.0**DET(2) C WITH 1.0 .LE. DABS(DET(1)) .LT. 10.0 C OR DET(1) .EQ. 0.0 . C C ERROR CONDITION C C A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS C A ZERO ON THE DIAGONAL AND THE INVERSE IS REQUESTED. C IT WILL NOT OCCUR IF THE SUBROUTINES ARE CALLED CORRECTLY C AND IF DGECO HAS SET RCOND .GT. 0.0 OR DGEFA HAS SET C INFO .EQ. 0 . C C LINPACK. THIS VERSION DATED 08/14/78 . C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. C C SUBROUTINES AND FUNCTIONS C C BLAS DAXPY,DSCAL,DSWAP C FORTRAN DABS,MOD C C INTERNAL VARIABLES C DOUBLE PRECISION T DOUBLE PRECISION TEN INTEGER I,J,K,KB,KP1,L,NM1 C C C COMPUTE DETERMINANT C IF (JOB/10 .EQ. 0) GO TO 70 DET(1) = 1.0D0 DET(2) = 0.0D0 TEN = 10.0D0 DO 50 I = 1, N IF (IPVT(I) .NE. I) DET(1) = -DET(1) DET(1) = A(I,I)*DET(1) C ...EXIT IF (DET(1) .EQ. 0.0D0) GO TO 60 10 IF (DABS(DET(1)) .GE. 1.0D0) GO TO 20 DET(1) = TEN*DET(1) DET(2) = DET(2) - 1.0D0 GO TO 10 20 CONTINUE 30 IF (DABS(DET(1)) .LT. TEN) GO TO 40 DET(1) = DET(1)/TEN DET(2) = DET(2) + 1.0D0 GO TO 30 40 CONTINUE 50 CONTINUE 60 CONTINUE 70 CONTINUE C C COMPUTE INVERSE(U) C IF (MOD(JOB,10) .EQ. 0) GO TO 150 DO 100 K = 1, N A(K,K) = 1.0D0/A(K,K) T = -A(K,K) CALL DSCAL(K-1,T,A(1,K),1) KP1 = K + 1 IF (N .LT. KP1) GO TO 90 DO 80 J = KP1, N T = A(K,J) A(K,J) = 0.0D0 CALL DAXPY(K,T,A(1,K),1,A(1,J),1) 80 CONTINUE 90 CONTINUE 100 CONTINUE C C FORM INVERSE(U)*INVERSE(L) C NM1 = N - 1 IF (NM1 .LT. 1) GO TO 140 DO 130 KB = 1, NM1 K = N - KB KP1 = K + 1 DO 110 I = KP1, N WORK(I) = A(I,K) A(I,K) = 0.0D0 110 CONTINUE DO 120 J = KP1, N T = WORK(J) CALL DAXPY(N,T,A(1,J),1,A(1,K),1) 120 CONTINUE L = IPVT(K) IF (L .NE. K) CALL DSWAP(N,A(1,K),1,A(1,L),1) 130 CONTINUE 140 CONTINUE 150 CONTINUE RETURN END SUBROUTINE ARCECO(N, ARRAY, MTRSTR, NMBLKS, PIVOT, B, X, IFLAG) C C*************************************************************** C C THIS PROGRAM SOLVES THE LINEAR SYSTEM A*X = B WHERE A IS C AN ALMOST BLOCK DIAGONAL MATRIX. THE METHOD IMPLEMENTED IS C BASED ON GAUSS ELIMINATION WITH ALTERNATE ROW AND COLUMN C ELIMINATION WITH PARTIAL PIVOTING, WHICH PRODUCES A STABLE C DECOMPOSITION OF THE MATRIX A WITHOUT INTRODUCING FILL-IN. C C*************************************************************** C C ***** PARAMETERS ***** C C *** ON ENTRY ... C C N - INTEGER C THE ORDER OF THE LINEAR SYSTEM, WHERE C N = SUM(MTRSTR(1,K),K=1,NMBLKS) C C ARRAY - REAL(NUMELS) C WHERE C NUMELS = SUM(MTRSTR(1,K)*MTRSTR(2,K), C K=1,NMBLKS). C CONTAINS THE ENTRIES OF THE ALMOST C BLOCK DIAGONAL MATRIX A WHOSE BLOCK C STRUCTURE IS GIVEN BY THE INTEGER ARRAY C MTRSTR. THE ELEMENTS OF A ARE STORED BY C COLUMNS, IN BLOCKS CORRESPONDING TO THE C GIVEN STRUCTURE. C C MTRSTR - INTEGER(3,NMBLKS) C DESCRIBES THE BLOCK STRUCTURE OF A ... C MTRSTR(1,K) = NUMBER OF ROWS IN C BLOCK K. C MTRSTR(2,K) = NUMBER OF COLUMNS IN C BLOCK K. C MTRSTR(3,K) = NUMBER OF COLUMNS C OVERLAPPED BY BLOCK K C AND BLOCK (K+1). C MTRSTR MUST SATISFY SOME RESTRICTIONS. C IN ORDER THAT A BE SQUARE, WE NEED C SUM(MTRSTR(1,K),K=1,NMBLKS) = N = C SUM((MTRSTR(2,K)-MTRSTR(3,K)),K=1,NMBLKS). C IN ADDITION, TO ENSURE THAT THREE SUCCESS- C IVE BLOCKS DO NOT HAVE COLUMNS IN COMMON, C MTRSTR MUST SATISFY C MTRSTR(3,K-1)+MTRSTR(3,K).LE.MTRSTR(2,K), C FOR K = 2,NMBLKS. C FINALLY, A R C E C O, SETS C MTRSTR(3,NMBLKS) = 0, IN ARCECD. C C NMBLKS - INTEGER C TOTAL NUMBER OF BLOCKS IN A C C PIVOT - INTEGER(N) C WORK SPACE C C B - REAL(N) C THE RIGHT HAND SIDE VECTOR C C X - REAL(N) C WORK SPACE C C *** ON RETURN ... C C ARRAY - REAL(NUMELS) C CONTAINS THE MODIFIED ALTERNATE ROW C AND COLUMN DECOMPOSITION OF A (IF C IFLAG = 0) C C PIVOT - INTEGER(N) C RECORDS THE PIVOTING INDICES DETER- C MINED IN THE DECOMPOSITION C C X - REAL(N) C THE SOLUTION VECTOR (IF IFLAG = 0) C C IFLAG - INTEGER C = 1,IF INPUT PARAMETERS ARE INVALID C = -1, IF MATRIX IS SINGULAR C = 0, OTHERWISE C C*************************************************************** C C ***** AUXILIARY PROGRAMS ***** C C ARCEDC(ARRAY,MTRSTR,NMBLKS,PIVOT,IFLAG) C - DECOMPOSES THE MATRIX A USING MODIFIED C ALTERNATE ROW AND COLUMN ELIMINATION C WITH PARTIAL PIVOTING, AND IS USED FOR C THIS PURPOSE IN A R C E C O. C THE ARGUMENTS ARE ALL AS IN A R C E C O. C C ARCESL(ARRAY,MTRSTR,NMBLKS,PIVOT,B,X) C - SOLVES THE SYSTEM A*X = B ONCE A IS C DECOMPOSED. C THE ARGUMENTS ARE ALL AS IN A R C E C O . C C*************************************************************** C C ***** BLOCK STRUCTURE OF A ***** C C THE NMBLKS BLOCKS OF A ARE STORED CONSECUTIVELY IN THE ONE C DIMENSIONAL MATRIX ARRAY, THE ENTRIES OF A BEING STORED C AS FOLLOWS ... C C IN ARRAY(1) THE (1,1) ENTRY OF THE TOP BLOCK, C C IN ARRAY(INDEX) THE (1,1) ENTRY OF THE ITH BLOCK WHERE C INDEX = 1 + SUM(MTRSTR(1,J)*MTRSTR(2,J), C J=1,I-1), I=2,NMBLKS. C C*************************************************************** C C THE SUBROUTINE A R C E C O AUTOMATICALLY SOLVES THE C INPUT SYSTEM WHEN IFLAG=0. A R C E C O IS CALLED ONLY ONCE C FOR A GIVEN SYSTEM. THE SOLUTION FOR A SEQUENCE OF P RIGHT C HAND SIDES CAN BE OBTAINED BY ONE CALL TO A R C E C O AND C P-1 CALLS TO ARCESL ONLY. SINCE THE ARRAYS ARRAY AND C PIVOT CONTAIN, RESPECTIVELY, THE DECOMPOSITION OF THE GIVEN C COEFFICIENT MATRIX AND PIVOTING INFORMATION ON RETURN FROM C A R C E C O , THEY MUST NOT BE ALTERED BETWEEN SUCCESSIVE C CALLS TO ARCESL WITH THE SAME RIGHT HAND SIDES. FOR THE C SAME REASON, IF THE USER WISHES TO SAVE THE COEFFICIENT C MATRIX, THE ARRAY ARRAY MUST BE COPIED BEFORE A CALL C TO A R C E C O . C C********************************************************************** REAL ARRAY, B, X INTEGER MTRSTR(3,*), PIVOT(*) DIMENSION ARRAY(*), B(*), X(*) CALL ARCEDC(N, ARRAY, MTRSTR, NMBLKS, PIVOT, IFLAG) IF (IFLAG.NE.0) RETURN CALL ARCESL(ARRAY, MTRSTR, NMBLKS, PIVOT, B, X) RETURN END SUBROUTINE ARCEDC(N, ARRAY, MTRSTR, NMBLKS, PIVOT, IFLAG) C C*************************************************************** C C A R C E D C SUPERVISES THE MODIFIED ALTERNATE ROW AND COLUMN C DECOMPOSITION WITH PARTIAL PIVOTING OF THE ALMOST BLOCK C DIAGONAL MATRIX A STORED IN THE ARRAYS A R R A Y AND C M T R S T R . C C*************************************************************** C C ***** PARAMETERS ***** C C *** ON ENTRY ... C C N - INTEGER C THE ORDER OF THE LINEAR SYSTEM, WHERE C N = SUM(MTRSTR(1,K),K=1,NMBLKS) C C ARRAY - REAL(NUMELS) C WHERE C NUMELS = SUM(MTRSTR(1,K)*MTRSTR(2,K), C K=1,NMBLKS). C CONTAINS THE ENTRIES OF THE ALMOST C BLOCK DIAGONAL MATRIX A WHOSE BLOCK C STRUCTURE IS GIVEN BY THE INTEGER ARRAY C MTRSTR. THE ELEMENTS OF A ARE STORED BY C COLUMNS, IN BLOCKS CORRESPONDING TO THE C GIVEN STRUCTURE. C MTRSTR - INTEGER(3,NMBLKS) C DESCRIBES THE BLOCK STRUCTURE OF A ... C MTRSTR(1,K) = NUMBER OF ROWS IN C BLOCK K. C MTRSTR(2,K) = NUMBER OF COLUMNS IN C BLOCK K. C MTRSTR(3,K) = NUMBER OF COLUMNS C OVERLAPPED BY BLOCK K C AND BLOCK (K+1). C MTRSTR MUST SATISFY SOME RESTRICTIONS. C IN ORDER THAT A BE SQUARE, WE NEED C SUM(MTRSTR(1,K),K=1,NMBLKS) = N = C SUM((MTRSTR(2,K)-MTRSTR(3,K)),K=1,NMBLKS). C IN ADDITION, TO ENSURE THAT THREE SUCCESS- C IVE BLOCKS DO NOT HAVE COLUMNS IN COMMON, C MTRSTR MUST SATISFY C MTRSTR(3,K-1)+MTRSTR(3,K).LE.MTRSTR(2,K), C FOR K = 2,NMBLKS. C FINALLY, A R C E C O, SETS C MTRSTR(3,NMBLKS) = 0, IN ARCECD. C C NMBLKS - INTEGER C TOTAL NUMBER OF BLOCKS C C PIVOT - INTEGER(N) C WORK SPACE C C *** ON RETURN ... C C ARRAY - REAL(NUMELS) C CONTAINS THE MODIFIED ALTERNATE ROW C AND COLUMN DECOMPOSITION OF A (IF C IFLAG = 0) C C PIVOT - INTEGER(N) C RECORDS THE PIVOTING INDICES DETER- C MINED IN THE DECOMPOSITION C C IFLAG - INTEGER C = 1, IF INPUT PARAMETERS ARE INVALID C = -1, IF MATRIX IS SINGULAR C = 0, OTHERWISE C C*************************************************************** C C ***** AUXILIARY PROGRAMS ***** C C ARCEPR(BLOCK,NRWBLK,NCLBLK,NRWPIV,PIVOT,PIVMAX,IFLAG) C CARRIES OUT THE ROW ELIMINATIONS C C ARCEPC(TOPBLK,NRWTOP,NOVRLP,BOTBLK,NRWBOT,NCLPIV, C PIVOT,PIVMAX,IFLAG) C CARRIES OUT THE COLUMN ELIMINATIONS C C*************************************************************** C REAL ARRAY, PIVMAX, ZERO INTEGER PIVOT(*) DIMENSION ARRAY(*), MTRSTR(3,*) DATA ZERO /0.0/ C C*************************************************************** C C **** CHECK VALIDITY OF THE INPUT PARAMETERS.... C C IF PARAMETERS ARE INVALID THEN TERMINATE AT 7, C ELSE CONTINUE AT 8. C C*************************************************************** C C MTRSTR(3,NMBLKS) = 0 DO 10 K=2,NMBLKS IF (MTRSTR(3,K-1)+MTRSTR(3,K).GT.MTRSTR(2,K)) GO TO 30 10 CONTINUE ISUM1 = 0 ISUM2 = 0 DO 20 K=1,NMBLKS ISUM1 = ISUM1 + MTRSTR(1,K) ISUM2 = ISUM2 + MTRSTR(2,K) - MTRSTR(3,K) 20 CONTINUE IF (ISUM1.NE.ISUM2) GO TO 30 IF (ISUM1.NE.N) GO TO 30 C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C PARAMETERS ARE ACCEPTABLE - CONTINUE AT 8 C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C GO TO 40 30 CONTINUE C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C PARAMETERS ARE INVALID. SET IFLAG = 1, AND TERMINATE C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IFLAG = 1 RETURN 40 CONTINUE C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C C INTERNAL PARAMETERS ... C C C C INDEX1 POINTER TO THE ELEMENT IN THE COLUMN C C WHERE ROW PIVOTING STARTS. C C C C INDEX2 POINTER TO THE ELEMENT IN THE COLUMN C C WHERE COLUMN PIVOTING STARTS. C C C C INDEX3 POINTER TO 1ST ELEMENT IN 1ST COLUMN C C OF NEXT BLOCK. C C C C INDPIV POINTER TO 1ST ELEMENT OF BLOCK OF PIVOT C C C C NRWBLK NUMBER OF ROWS IN BLOCK. C C C C NRWBK2 NUMBER OF ROWS IN NEXT BLOCK. C C C C NRWPIV NUMBER OF ROW ELIMINATIONS. C C C C NCLBLK NUMBER OF COLUMNS IN BLOCK TO BE C C ROW PIVOTED. C C C C NCLPIV NUMBER OF COLUMN ELIMINATIONS. C C C C NOVRLP NUMBER OF COLUMNS OVERLAPPED BY THE C C CURRENT BLOCK AND THE NEXT BLOCK. C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C PIVMAX = ZERO IFLAG = 0 INDEX1 = 1 INDPIV = 1 NRWBLK = MTRSTR(1,1) NCLBLK = MTRSTR(2,1) NOVRLP = MTRSTR(3,1) NRWPIV = NCLBLK - NOVRLP C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C C CALL ARCEPR TO PERFORM NRWPIV ROW ELIMINATIONS C C ON TOP BLOCK. C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IF (NRWPIV.GT.0) CALL ARCEPR(ARRAY(INDEX1), NRWBLK, NCLBLK, * NRWPIV, PIVOT(INDPIV), PIVMAX, IFLAG) C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C C IF MATRIX SINGULAR RETURN. C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IF (IFLAG.LT.0) RETURN C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C C NOW DO DECOMPOSITION PROCEEDING ONE BLOCK AT A C C TIME. C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C DO 70 K=2,NMBLKS INDPIV = INDPIV + NRWPIV INDEX2 = INDEX1 + NRWBLK*NRWPIV INDEX3 = INDEX2 + NRWBLK*NOVRLP NCLPIV = NRWBLK - NRWPIV NRWBK2 = MTRSTR(1,K) C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C C CALL ARCEPC TO PERFORM NCLPIV COLUMN ELIMINATIONS. C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IF (NCLPIV.EQ.0) GO TO 50 CALL ARCEPC(ARRAY(INDEX2), NRWBLK, NOVRLP, ARRAY(INDEX3), * NRWBK2, NCLPIV, PIVOT(INDPIV), PIVMAX, IFLAG) C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C C IF MATRIX IS SINGULAR RETURN. C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IF (IFLAG.LT.0) RETURN 50 CONTINUE NRWBLK = NRWBK2 INDEX1 = INDEX3 + NRWBLK*NCLPIV NCLBLK = MTRSTR(2,K) - NCLPIV NOVRLP = MTRSTR(3,K) NRWPIV = NCLBLK - NOVRLP INDPIV = INDPIV + NCLPIV C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C C CALL ARCEPR TO PERFORM NRWPIV ROW ELIMINATIONS. C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IF (NRWPIV.EQ.0) GO TO 60 CALL ARCEPR(ARRAY(INDEX1), NRWBLK, NCLBLK, NRWPIV, * PIVOT(INDPIV), PIVMAX, IFLAG) C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C C IF MATRIX IS SINGULAR RETURN. C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IF (IFLAG.LT.0) RETURN 60 CONTINUE 70 CONTINUE RETURN END SUBROUTINE ARCEPR(BLOCK, NRWBLK, NCLBLK, NRWPIV, PIVOT, PIVMAX, * IFLAG) C C*************************************************************** C C A R C E P R PERFORMS NRWPIV ROW ELIMINATIONS ON THE MATRIX C BLOCK C C*************************************************************** C INTEGER PIVOT(NRWBLK) REAL BLOCK, ROWMAX, PIVMAX, TEMPIV, ROWPIV, SWAP DIMENSION BLOCK(NRWBLK,NCLBLK) C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C C PERFORM NRWPIV ROW ELIMINATIONS... C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C DO 90 J=1,NRWPIV JPLUS1 = J + 1 C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C C DETERMINE ROW PIVOT AND PIVOT INDEX C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C MAX = J ROWMAX = ABS(BLOCK(J,J)) IF (J.EQ.NRWBLK) GO TO 30 DO 20 I1=JPLUS1,NRWBLK TEMPIV = ABS(BLOCK(I1,J)) IF (TEMPIV.LE.ROWMAX) GO TO 10 ROWMAX = TEMPIV MAX = I1 10 CONTINUE 20 CONTINUE 30 CONTINUE C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C C TEST FOR SINGULARITY ... C C C C IF SINGULAR THEN TERMINATE AT 90, C C ELSE CONTINUE. C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IF (PIVMAX+ROWMAX.EQ.PIVMAX) GO TO 100 PIVMAX = AMAX1(PIVMAX,ROWMAX) C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C C IF NECESSARY INTERCHANGE ROWS C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C PIVOT(J) = MAX IF (J.EQ.MAX) GO TO 50 DO 40 J1=J,NCLBLK SWAP = BLOCK(MAX,J1) BLOCK(MAX,J1) = BLOCK(J,J1) BLOCK(J,J1) = SWAP 40 CONTINUE 50 CONTINUE IF (J.EQ.NRWBLK) RETURN C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C C COMPUTE THE MULTIPLIERS C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C ROWPIV = BLOCK(J,J) DO 60 I1=JPLUS1,NRWBLK BLOCK(I1,J) = BLOCK(I1,J)/ROWPIV 60 CONTINUE C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C C PERFORM ROW ELIMINATIONS WITH COLUMN INDEXING C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C DO 80 J1=JPLUS1,NCLBLK DO 70 L1=JPLUS1,NRWBLK BLOCK(L1,J1) = BLOCK(L1,J1) - BLOCK(L1,J)*BLOCK(J,J1) 70 CONTINUE 80 CONTINUE 90 CONTINUE RETURN 100 CONTINUE C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C C MATRIX IS SINGULAR - SET IFLAG = -1. C C TERMINATE AT 90. C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IFLAG = -1 RETURN END SUBROUTINE ARCEPC(TOPBLK, NRWTOP, NOVRLP, BOTBLK, NRWBOT, NCLPIV, * PIVOT, PIVMAX, IFLAG) C C*************************************************************** C C A R C E P C PERFORMS NCLPIV COLUMN ELIMINATIONS ON THE C MATRICES TOPBLK AND BOTBLK C*************************************************************** C REAL TOPBLK, BOTBLK, COLMAX, PIVMAX, COLMLT REAL TEMPIV, SWAP INTEGER PIVOT(NRWTOP) DIMENSION TOPBLK(NRWTOP,NOVRLP), BOTBLK(NRWBOT,NOVRLP) C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C C PERFORM THE COLUMN ELIMINATIONS ON A LOOP. C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C DO 110 J=1,NCLPIV I = NRWTOP - NCLPIV + J C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C C DETERMINE COLUMN PIVOT AND PIVOT INDEX C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C MAX = J COLMAX = ABS(TOPBLK(I,J)) IF (J.EQ.NOVRLP) GO TO 30 JPLUS1 = J + 1 DO 20 J1=JPLUS1,NOVRLP TEMPIV = ABS(TOPBLK(I,J1)) IF (TEMPIV.LE.COLMAX) GO TO 10 COLMAX = TEMPIV MAX = J1 10 CONTINUE 20 CONTINUE 30 CONTINUE C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C C TEST FOR SINGULARITY ... C C C C IF SINGULAR THEN TERMINATE AT 110, C C ELSE CONTINUE. C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IF (PIVMAX+COLMAX.EQ.PIVMAX) GO TO 120 PIVMAX = AMAX1(PIVMAX,COLMAX) C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C C IF NECESSARY INTERCHANGE COLUMNS C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C PIVOT(J) = MAX IF (J.EQ.MAX) GO TO 60 DO 40 I1=I,NRWTOP SWAP = TOPBLK(I1,J) TOPBLK(I1,J) = TOPBLK(I1,MAX) TOPBLK(I1,MAX) = SWAP 40 CONTINUE DO 50 I2=1,NRWBOT SWAP = BOTBLK(I2,J) BOTBLK(I2,J) = BOTBLK(I2,MAX) BOTBLK(I2,MAX) = SWAP 50 CONTINUE 60 CONTINUE IF (J.EQ.NOVRLP) RETURN C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C C COMPUTE MULTIPLIERS AND PERFORM COLUMN C C ELIMINATION C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C DO 100 J1=JPLUS1,NOVRLP COLMLT = TOPBLK(I,J1)/TOPBLK(I,J) TOPBLK(I,J1) = COLMLT IF (I.EQ.NRWTOP) GO TO 80 IPLUS1 = I + 1 DO 70 L1=IPLUS1,NRWTOP TOPBLK(L1,J1) = TOPBLK(L1,J1) - COLMLT*TOPBLK(L1,J) 70 CONTINUE 80 CONTINUE DO 90 L1=1,NRWBOT BOTBLK(L1,J1) = BOTBLK(L1,J1) - COLMLT*BOTBLK(L1,J) 90 CONTINUE 100 CONTINUE 110 CONTINUE RETURN 120 CONTINUE C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C C MATRIX IS SINGULAR - SET IFLAG = -1. C C TERMINATE AT 110. C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IFLAG = -1 RETURN END SUBROUTINE ARCESL(ARRAY, MTRSTR, NMBLKS, PIVOT, B, X) C C*************************************************************** C C A R C E S L SUPERVISES THE SOLUTION OF THE LINEAR SYSTEM C A*X = B C USING THE DECOMPOSITION OF THE MATRIX A ALREADY GENERATED C IN A R C E D C. IT INVOLVES TWO LOOPS, THE FORWARD LOOP, C CONSISTING OF FORWARD SOLUTION, FORWARD MODIFICATION, AND C FORWARD ELIMINATION, AND THE BACKWARD LOOP, CONSISTING OF C BACKWARD SOLUTION, BACKWARD MODIFICATION, AND BACKWARD C ELIMINATION. C C*************************************************************** C C ***** PARAMETERS ***** C C *** ON ENTRY ... C C ARRAY - REAL(NUMELS) C WHERE C NUMELS = SUM(MTRSTR(1,K)*MTRSTR(2,K), C K=1,NMBLKS). C OUTPUT FROM A R C E D C C C MTRSTR - INTEGER(3,NMBLKS) C DESCRIBES THE BLOCK STRUCTURE OF A ... C MTRSTR(1,K) = NUMBER OF ROWS IN C BLOCK K. C MTRSTR(2,K) = NUMBER OF COLUMNS IN C BLOCK K. C MTRSTR(3,K) = NUMBER OF COLUMNS C OVERLAPPED BY BLOCK K C AND BLOCK (K+1). C C THE LINEAR SYSTEM IS OF ORDER C N = SUM(MTRSTR(1,K),K=1,NMBLKS) C C NMBLKS - INTEGER C TOTAL NUMBER OF BLOCKS IN A C C PIVOT - INTEGER(N) C OUTPUT FROM A R C E D C C C B - REAL(N) C THE RIGHT HAND SIDE VECTOR C C X - REAL(N) C WORK SPACE C C *** ON RETURN ... C C C X - REAL(N) C THE SOLUTION VECTOR C C*************************************************************** C C ***** AUXILIARY PROGRAMS ***** C C C ARCEFS - PERFORMS FORWARD SOLUTION STEP C C ARCEFM - PERFORMS FORWARD MODIFICATION STEP C C ARCEFE - PERFORMS FORWARD ELIMINATION STEP C C ARCEBS - PERFORMS BACKWARD SOLUTION STEP C C ARCEBM - PERFORMS BACKWARD MODIFICATION STEP C C ARCEBE - PERFORMS BACKWARD ELIMINATION STEP C C*************************************************************** C REAL ARRAY, B, X INTEGER PIVOT(*) DIMENSION ARRAY(*), MTRSTR(3,*), B(*), X(*) INDPIV = 1 C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C C INTERNAL PARAMETERS ... C C C C INDEXA POINTER TO 1ST ELEMENT OF BLOCK OF A. C C C C INDEXB POINTER TO 1ST ELEMENT OF BLOCK OF B. C C C C INDPIV,NRWBLK,NRWPIV,NCLBLK,NCLPIV,NOVRLP C C ARE AS IN ARCEDC. C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C INDEXA = 1 NRWBLK = MTRSTR(1,1) NCLBLK = MTRSTR(2,1) NOVRLP = MTRSTR(3,1) NRWPIV = NCLBLK - NOVRLP C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C C CALL ARCEFE TO PERFORM FORWARD ELIMINATION. C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IF (NRWPIV.GT.0) CALL ARCEFE(ARRAY(INDEXA), NRWBLK, NRWPIV, * PIVOT(INDPIV), B(INDPIV)) C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C C FORWARD LOOP C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C DO 10 K=2,NMBLKS INDEXA = INDEXA + NRWBLK*NRWPIV NCLPIV = NRWBLK - NRWPIV INDPIV = INDPIV + NRWPIV C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C C CALL ARCEFS TO PERFORM FORWARD SOLUTION C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IF (NCLPIV.GT.0) CALL ARCEFS(ARRAY(INDEXA), NRWBLK, NCLPIV, * NOVRLP, B(INDPIV), X(INDPIV)) INDEXA = INDEXA + NOVRLP*NRWBLK NRWBLK = MTRSTR(1,K) C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C C CALL ARCEFM TO PERFORM FORWARD MODIFICATION C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IF (NCLPIV.GT.0) CALL ARCEFM(ARRAY(INDEXA), NRWBLK, NCLPIV, * B(INDPIV), X(INDPIV)) INDEXA = INDEXA + NRWBLK*NCLPIV NCLBLK = MTRSTR(2,K) - NCLPIV NOVRLP = MTRSTR(3,K) NRWPIV = NCLBLK - NOVRLP INDPIV = INDPIV + NCLPIV C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C C CALL ARCEFE TO PERFORM FORWARD ELIMINATION C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IF (NRWPIV.GT.0) CALL ARCEFE(ARRAY(INDEXA), NRWBLK, NRWPIV, * PIVOT(INDPIV), B(INDPIV)) 10 CONTINUE C INDEXB = INDPIV + NRWPIV - 1 C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C C BACKWARD LOOP C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C DO 30 LL=2,NMBLKS K = NMBLKS - LL + 1 C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C C CALL ARCEBM TO PERFORM BACKWARD MODIFICATION C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IF (NRWPIV.EQ.0) GO TO 20 IF (NRWPIV.NE.NCLBLK) CALL ARCEBM(ARRAY(INDEXA), NRWBLK, * NCLBLK, NRWPIV, B(INDPIV), X(INDPIV)) C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C C CALL ARCEBS TO PERFORM BACKWARD SOLUTION C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C CALL ARCEBS(ARRAY(INDEXA), NRWBLK, NCLBLK, NRWPIV, B(INDPIV), * X(INDPIV)) 20 CONTINUE INDEXA = INDEXA - NRWBLK*NCLPIV NRWBLK = MTRSTR(1,K) NOVRLP = MTRSTR(3,K) INDEXA = INDEXA - NRWBLK*NOVRLP INDPIV = INDPIV - NCLPIV C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C C CALL ARCEBE TO PERFORM BACKWARD ELIMINATION C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IF (NCLPIV.GT.0) CALL ARCEBE(ARRAY(INDEXA), NRWBLK, NCLPIV, * NOVRLP, PIVOT(INDPIV), X(INDPIV)) NRWPIV = NRWBLK - NCLPIV NCLBLK = NOVRLP + NRWPIV INDEXA = INDEXA - NRWBLK*NRWPIV INDPIV = INDPIV - NRWPIV NCLPIV = MTRSTR(2,K) - NCLBLK 30 CONTINUE C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C C C IF ROW ELIMINATIONS WERE DONE IN TOPBLOCK, CALL C C ARCEBS TO PERFORM BACKWARD SOLUTION C C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IF (NRWPIV.EQ.0) RETURN IF (NRWPIV.NE.NCLBLK) CALL ARCEBM(ARRAY(INDEXA), NRWBLK, NCLBLK, * NRWPIV, B(INDPIV), X(INDPIV)) CALL ARCEBS(ARRAY(INDEXA), NRWBLK, NCLBLK, NRWPIV, B(INDPIV), * X(INDPIV)) RETURN END SUBROUTINE ARCEFS(BLOCK, NRWBLK, NCLPIV, NOVRLP, B, X) C C*************************************************************** C C A R C E F S PERFORMS THE FORWARD SOLUTION STEP IN THE C SOLUTION PHASE OF A R C E C O. C C*************************************************************** C REAL BLOCK, B, X, XJ DIMENSION BLOCK(NRWBLK,NOVRLP), B(*), X(*) DO 20 J=1,NCLPIV I = NRWBLK - NCLPIV + J X(J) = B(J)/BLOCK(I,J) IF (I.EQ.NRWBLK) RETURN LONG = NRWBLK - I XJ = X(J) DO 10 L=1,LONG IPLUSL = I + L JPLUSL = J + L B(JPLUSL) = B(JPLUSL) - BLOCK(IPLUSL,J)*XJ 10 CONTINUE 20 CONTINUE RETURN END SUBROUTINE ARCEFM(BLOCK, NRWBLK, NCLPIV, B, X) C C*************************************************************** C C A R C E F M PERFORMS THE FORWARD MODIFICATION STEP IN THE C SOLUTION PHASE OF A R C E C O. C C*************************************************************** C REAL BLOCK, B, X, XJ DIMENSION BLOCK(NRWBLK,NCLPIV), B(*), X(*) DO 20 J=1,NCLPIV XJ = X(J) DO 10 L=1,NRWBLK NCLPVL = NCLPIV + L B(NCLPVL) = B(NCLPVL) - BLOCK(L,J)*XJ 10 CONTINUE 20 CONTINUE RETURN END SUBROUTINE ARCEFE(BLOCK, NRWBLK, NRWPIV, PIVOT, B) C C*************************************************************** C C A R C E F E PERFORMS THE FORWARD ELIMINATION STEP IN THE C SOLUTION PHASE OF A R C E C O. C C*************************************************************** C REAL BLOCK, B, BI, SWAP INTEGER PIVOT(NRWPIV), PIVOTI DIMENSION BLOCK(NRWBLK,NRWPIV), B(*) DO 30 I=1,NRWPIV PIVOTI = PIVOT(I) IF (PIVOTI.EQ.I) GO TO 10 SWAP = B(I) B(I) = B(PIVOTI) B(PIVOTI) = SWAP 10 CONTINUE IF (I.EQ.NRWBLK) RETURN BI = B(I) IPLUS1 = I + 1 DO 20 L=IPLUS1,NRWBLK B(L) = B(L) - BLOCK(L,I)*BI 20 CONTINUE 30 CONTINUE RETURN END SUBROUTINE ARCEBS(BLOCK, NRWBLK, NCLBLK, NRWPIV, B, X) C C*************************************************************** C C A R C E B S PERFORMS THE BACKWARD SOLUTION STEP IN THE C SOLUTION PHASE OF A R C E C O. C C*************************************************************** C REAL BLOCK, B, X, XJ DIMENSION BLOCK(NRWBLK,NCLBLK), B(*), X(*) DO 20 NJ=1,NRWPIV J = NRWPIV - NJ + 1 X(J) = B(J)/BLOCK(J,J) IF (J.EQ.1) RETURN JMIN1 = J - 1 XJ = X(J) DO 10 L=1,JMIN1 B(L) = B(L) - BLOCK(L,J)*XJ 10 CONTINUE 20 CONTINUE RETURN END SUBROUTINE ARCEBM(BLOCK, NRWBLK, NCLBLK, NRWPIV, B, X) C C*************************************************************** C C A R C E B M PERFORMS THE BACKWARD MODIFICATION STEP IN THE C SOLUTION PHASE OF A R C E C O. C C*************************************************************** C REAL BLOCK, B, X, XJ DIMENSION BLOCK(NRWBLK,NCLBLK), B(*), X(*) NRWPV1 = NRWPIV + 1 DO 20 J=NRWPV1,NCLBLK XJ = X(J) DO 10 L=1,NRWPIV B(L) = B(L) - BLOCK(L,J)*XJ 10 CONTINUE 20 CONTINUE RETURN END SUBROUTINE ARCEBE(BLOCK, NRWBLK, NCLPIV, NOVRLP, PIVOT, X) C C*************************************************************** C C A R C E B E PERFORMS THE BACKWARD ELIMINATION STEP IN THE C SOLUTION PHASE OF A R C E C O. C C*************************************************************** C REAL BLOCK, X, DOTPRD, SWAP INTEGER PIVOT(NRWBLK), PIVOTJ DIMENSION BLOCK(NRWBLK,NOVRLP), X(*) DO 40 NJ=1,NCLPIV J = NCLPIV + 1 - NJ I = NRWBLK + 1 - NJ DOTPRD = X(J) IF (J.EQ.NOVRLP) GO TO 20 JPLUS1 = J + 1 DO 10 J1=JPLUS1,NOVRLP DOTPRD = DOTPRD - X(J1)*BLOCK(I,J1) 10 CONTINUE 20 CONTINUE X(J) = DOTPRD PIVOTJ = PIVOT(J) IF (PIVOTJ.EQ.J) GO TO 30 SWAP = X(PIVOTJ) X(PIVOTJ) = X(J) X(J) = SWAP 30 CONTINUE 40 CONTINUE RETURN END SUBROUTINE BTSLV(MO, M, N, A, B, C, X, IP, IERR) INTEGER MO, M , N, IP(M,N) REAL A(M,M,N), B(M,M,N), C(M,M,N), X(*) C C DECOMPOSE THE COEFFICIENT MATRIX C IF (MO .NE. 0) GO TO 10 CALL DECBT(M, N, A, B, C, IP, IERR) IF (IERR .NE. 0) RETURN C C SOLVE THE SYSTEM OF EQUATIONS C 10 CALL SOLBT(M, N, A, B, C, X, IP) RETURN END SUBROUTINE DECBT (M, N, A, B, C, IP, IER) INTEGER M, N, IP(M,N), IER REAL A(M,M,N), B(M,M,N), C(M,M,N) C----------------------------------------------------------------------- C BLOCK-TRIDIAGONAL MATRIX DECOMPOSITION ROUTINE. C WRITTEN BY A. C. HINDMARSH. C LATEST REVISION JANUARY 26, 1977 (AG) C REFERENCE.. UCID-30150 C SOLUTION OF BLOCK-TRIDIAGONAL SYSTEMS OF LINEAR C ALGEBRAIC EQUATIONS C A.C. HINDMARSH C FEBRUARY 1977 C THE INPUT MATRIX CONTAINS THREE BLOCKS OF ELEMENTS IN EACH BLOCK-ROW, C INCLUDING BLOCKS IN THE (1,3) AND (N,N-2) BLOCK POSITIONS. C DECBT USES BLOCK GAUSS ELIMINATION AND SUBROUTINES DEC AND SOL C FOR SOLUTION OF BLOCKS. PARTIAL PIVOTING IS DONE WITHIN C BLOCK-ROWS ONLY. C INPUT.. C M = ORDER OF EACH BLOCK. C N = NUMBER OF BLOCKS IN EACH DIRECTION OF THE MATRIX. C N MUST BE 4 OR MORE. THE COMPLETE MATRIX HAS ORDER M*N. C A = M BY M BY N ARRAY CONTAINING DIAGONAL BLOCKS. C A(I,J,K) CONTAINS THE (I,J) ELEMENT OF THE K-TH BLOCK. C B = M BY M BY N ARRAY CONTAINING THE SUPER-DIAGONAL BLOCKS C (IN B(*,*,K) FOR K = 1,...,N-1) AND THE BLOCK IN THE (N,N-2) C BLOCK POSITION (IN B(*,*,N)). C C = M BY M BY N ARRAY CONTAINING THE SUBDIAGONAL BLOCKS C (IN C(*,*,K) FOR K = 2,3,...,N) AND THE BLOCK IN THE C (1,3) BLOCK POSITION (IN C(*,*,1)). C IP = INTEGER ARRAY OF LENGTH M*N FOR WORKING STORAGE. C OUTPUT.. C A,B,C = M BY M BY N ARRAYS CONTAINING THE BLOCK LU DECOMPOSITION C OF THE INPUT MATRIX. C IP = M BY N ARRAY OF PIVOT INFORMATION. IP(*,K) CONTAINS C INFORMATION FOR THE K-TH DIGONAL BLOCK. C IER = 0 IF NO TROUBLE OCCURRED, OR C = -1 IF THE INPUT VALUE OF M OR N WAS ILLEGAL, OR C = K IF A SINGULAR MATRIX WAS FOUND IN THE K-TH DIAGONAL BLOCK. C USE SOLBT TO SOLVE THE ASSOCIATED LINEAR SYSTEM. C DECBT CALLS SUBROUTINES DEC(M,M0,A,IP,IER) AND SOL(M,M0,A,Y,IP) C FOR SOLUTION OF M BY M LINEAR SYSTEMS. C----------------------------------------------------------------------- INTEGER NM1, NM2, KM1,I,J,K,L REAL DP C IF (M .LT. 1 .OR. N .LT. 4) GO TO 210 NM1 = N - 1 NM2 = N - 2 C PROCESS THE FIRST BLOCK-ROW. ----------------------------------------- CALL DEC (M, M, A, IP, IER) K = 1 IF (IER .NE. 0) GO TO 200 DO 10 J = 1,M CALL SOL (M, M, A, B(1,J,1), IP) CALL SOL (M, M, A, C(1,J,1), IP) 10 CONTINUE C ADJUST B(*,*,2). ----------------------------------------------------- DO 40 J = 1,M DO 30 I = 1,M DP = 0. DO 20 L = 1,M 20 DP = DP + C(I,L,2)*C(L,J,1) B(I,J,2) = B(I,J,2) - DP 30 CONTINUE 40 CONTINUE C MAIN LOOP. PROCESS BLOCK-ROWS 2 TO N-1. ----------------------------- DO 100 K = 2,NM1 KM1 = K - 1 DO 70 J = 1,M DO 60 I = 1,M DP = 0. DO 50 L = 1,M 50 DP = DP + C(I,L,K)*B(L,J,KM1) A(I,J,K) = A(I,J,K) - DP 60 CONTINUE 70 CONTINUE CALL DEC (M, M, A(1,1,K), IP(1,K), IER) IF (IER .NE. 0) GO TO 200 DO 80 J = 1,M 80 CALL SOL (M, M, A(1,1,K), B(1,J,K), IP(1,K)) 100 CONTINUE C PROCESS LAST BLOCK-ROW AND RETURN. ----------------------------------- DO 130 J = 1,M DO 120 I = 1,M DP = 0. DO 110 L = 1,M 110 DP = DP + B(I,L,N)*B(L,J,NM2) C(I,J,N) = C(I,J,N) - DP 120 CONTINUE 130 CONTINUE DO 160 J = 1,M DO 150 I = 1,M DP = 0. DO 140 L = 1,M 140 DP = DP + C(I,L,N)*B(L,J,NM1) A(I,J,N) = A(I,J,N) - DP 150 CONTINUE 160 CONTINUE CALL DEC (M, M, A(1,1,N), IP(1,N), IER) K = N IF (IER .NE. 0) GO TO 200 RETURN C ERROR RETURNS. ------------------------------------------------------- 200 IER = K RETURN 210 IER = -1 RETURN C----------------------- END OF SUBROUTINE DECBT --------------------- END SUBROUTINE SOLBT (M, N, A, B, C, Y, IP) INTEGER M, N, IP(M,N) REAL A(M,M,N), B(M,M,N), C(M,M,N), Y(M,N) C----------------------------------------------------------------------- C SOLUTION OF BLOCK-TRIDIAGONAL LINEAR SYSTEM. C COEFFICIENT MATRIX MUST HAVE BEEN PREVIOUSLY PROCESSED BY DECBT. C M, N, A, B, C, AND IP MUST NOT HAVE BEEN CHANGED SINCE CALL TO DECBT. C WRITTEN BY A. C. HINDMARSH. C INPUT.. C M = ORDER OF EACH BLOCK. C N = NUMBER OF BLOCKS IN EACH DIRECTION OF MATRIX. C A,B,C = M BY M BY N ARRAYS CONTAINING BLOCK LU DECOMPOSITION C OF COEFFICIENT MATRIX FROM DECBT. C IP = M BY N INTEGER ARRAY OF PIVOT INFORMATION FROM DECBT. C Y = ARRAY OF LENGTH M*N CONTAINING THE RIGHT-HAND SIDE VECTOR C (TREATED AS AN M BY N ARRAY HERE). C OUTPUT.. C Y = SOLUTION VECTOR, OF LENGTH M*N. C SOLBT MAKES CALLS TO SUBROUTINE SOL(M,M0,A,Y,IP) C FOR SOLUTION OF M BY M LINEAR SYSTEMS. C----------------------------------------------------------------------- INTEGER NM1, NM2, KM1, I, J, K REAL DP C NM1 = N - 1 NM2 = N - 2 C FORWARD SOLUTION SWEEP. ---------------------------------------------- CALL SOL (M, M, A, Y, IP) DO 30 K = 2,NM1 KM1 = K - 1 DO 20 I = 1,M DP = 0. DO 10 J = 1,M 10 DP = DP + C(I,J,K)*Y(J,KM1) Y(I,K) = Y(I,K) - DP 20 CONTINUE CALL SOL (M, M, A(1,1,K), Y(1,K), IP(1,K)) 30 CONTINUE DO 50 I = 1,M DP = 0. DO 40 J = 1,M 40 DP = DP + C(I,J,N)*Y(J,NM1) + B(I,J,N)*Y(J,NM2) Y(I,N) = Y(I,N) - DP 50 CONTINUE CALL SOL (M, M, A(1,1,N), Y(1,N), IP(1,N)) C BACKWARD SOLUTION SWEEP. --------------------------------------------- DO 80 KB = 1,NM1 K = N - KB KP1 = K + 1 DO 70 I = 1,M DP = 0. DO 60 J = 1,M 60 DP = DP + B(I,J,K)*Y(J,KP1) Y(I,K) = Y(I,K) - DP 70 CONTINUE 80 CONTINUE DO 100 I = 1,M DP = 0. DO 90 J = 1,M 90 DP = DP + C(I,J,1)*Y(J,3) Y(I,1) = Y(I,1) - DP 100 CONTINUE RETURN C----------------------- END OF SUBROUTINE SOLBT --------------------- END SUBROUTINE SMSLV(MO,N,M,A,B,KB,DET,RCOND,INERT,IERR,IPVT,WK) C ------------------ REAL A(*),B(*) REAL DET(2),RCOND,T,WK(N) INTEGER INERT(3),IPVT(N),ONEJ C ------------------ C C MATRIX FACTORIZATION AND COMPUTATION OF RCOND C IERR = 0 CALL SSPCO(A,N,IPVT,RCOND,WK) T = 1.0 + RCOND IF (T .EQ. 1.0) GO TO 30 C C SOLUTION OF THE EQUATION AX=B C IF (M .LT. 1) GO TO 20 ONEJ = 1 DO 10 J=1,M CALL SSPSL(A,N,IPVT,B(ONEJ)) 10 ONEJ = ONEJ + KB C C CALCULATION OF DET AND THE INVERSE OF A C 20 JOB = 110 IF (MO .EQ. 0) JOB = 111 CALL SSPDI(A,N,IPVT,DET,INERT,WK,JOB) RETURN C C THE PROBLEM CANNOT BE SOLVED C 30 IERR = 1 RETURN END SUBROUTINE SSPCO(AP,N,KPVT,RCOND,Z) INTEGER N,KPVT(*) REAL AP(*),Z(*) REAL RCOND C C SSPCO FACTORS A REAL SYMMETRIC MATRIX STORED IN PACKED C FORM BY ELIMINATION WITH SYMMETRIC PIVOTING AND ESTIMATES C THE CONDITION OF THE MATRIX. C C IF RCOND IS NOT NEEDED, SSPFA IS SLIGHTLY FASTER. C TO SOLVE A*X = B , FOLLOW SSPCO BY SSPSL. C TO COMPUTE INVERSE(A)*C , FOLLOW SSPCO BY SSPSL. C TO COMPUTE INVERSE(A) , FOLLOW SSPCO BY SSPDI. C TO COMPUTE DETERMINANT(A) , FOLLOW SSPCO BY SSPDI. C TO COMPUTE INERTIA(A), FOLLOW SSPCO BY SSPDI. C C ON ENTRY C C AP REAL (N*(N+1)/2) C THE PACKED FORM OF A SYMMETRIC MATRIX A . THE C COLUMNS OF THE UPPER TRIANGLE ARE STORED SEQUENTIALLY C IN A ONE-DIMENSIONAL ARRAY OF LENGTH N*(N+1)/2 . C SEE COMMENTS BELOW FOR DETAILS. C C N INTEGER C THE ORDER OF THE MATRIX A . C C OUTPUT C C AP A BLOCK DIAGONAL MATRIX AND THE MULTIPLIERS WHICH C WERE USED TO OBTAIN IT STORED IN PACKED FORM. C THE FACTORIZATION CAN BE WRITTEN A = U*D*TRANS(U) C WHERE U IS A PRODUCT OF PERMUTATION AND UNIT C UPPER TRIANGULAR MATRICES , TRANS(U) IS THE C TRANSPOSE OF U , AND D IS BLOCK DIAGONAL C WITH 1 BY 1 AND 2 BY 2 BLOCKS. C C KPVT INTEGER(N) C AN INTEGER VECTOR OF PIVOT INDICES. C C RCOND REAL C AN ESTIMATE OF THE RECIPROCAL CONDITION OF A . C FOR THE SYSTEM A*X = B , RELATIVE PERTURBATIONS C IN A AND B OF SIZE EPSILON MAY CAUSE C RELATIVE PERTURBATIONS IN X OF SIZE EPSILON/RCOND . C IF RCOND IS SO SMALL THAT THE LOGICAL EXPRESSION C 1.0 + RCOND .EQ. 1.0 C IS TRUE, THEN A MAY BE SINGULAR TO WORKING C PRECISION. IN PARTICULAR, RCOND IS ZERO IF C EXACT SINGULARITY IS DETECTED OR THE ESTIMATE C UNDERFLOWS. C C Z REAL(N) C A WORK VECTOR WHOSE CONTENTS ARE USUALLY UNIMPORTANT. C IF A IS CLOSE TO A SINGULAR MATRIX, THEN Z IS C AN APPROXIMATE NULL VECTOR IN THE SENSE THAT C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . C C PACKED STORAGE C C THE FOLLOWING PROGRAM SEGMENT WILL PACK THE UPPER C TRIANGLE OF A SYMMETRIC MATRIX. C C K = 0 C DO 20 J = 1, N C DO 10 I = 1, J C K = K + 1 C AP(K) = A(I,J) C 10 CONTINUE C 20 CONTINUE C C LINPACK. THIS VERSION DATED 08/14/78 . C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. C C SUBROUTINES AND FUNCTIONS C C LINPACK SSPFA C BLAS SAXPY,SDOT,SSCAL,SASUM C FORTRAN ABS,AMAX1,IABS,SIGN C C INTERNAL VARIABLES C REAL AK,AKM1,BK,BKM1,SDOT,DENOM,EK,T REAL ANORM,S,SASUM,YNORM INTEGER I,IJ,IK,IKM1,IKP1,INFO,J,JM1,J1 INTEGER K,KK,KM1K,KM1KM1,KP,KPS,KS C C C FIND NORM OF A USING ONLY UPPER HALF C J1 = 1 DO 30 J = 1, N Z(J) = SASUM(J,AP(J1),1) IJ = J1 J1 = J1 + J JM1 = J - 1 IF (JM1 .LT. 1) GO TO 20 DO 10 I = 1, JM1 Z(I) = Z(I) + ABS(AP(IJ)) IJ = IJ + 1 10 CONTINUE 20 CONTINUE 30 CONTINUE ANORM = 0.0E0 DO 40 J = 1, N ANORM = AMAX1(ANORM,Z(J)) 40 CONTINUE C C FACTOR C CALL SSPFA(AP,N,KPVT,INFO) C C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL C GROWTH IN THE ELEMENTS OF W WHERE U*D*W = E . C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. C C SOLVE U*D*W = E C EK = 1.0E0 DO 50 J = 1, N Z(J) = 0.0E0 50 CONTINUE K = N IK = (N*(N - 1))/2 60 IF (K .EQ. 0) GO TO 120 KK = IK + K IKM1 = IK - (K - 1) KS = 1 IF (KPVT(K) .LT. 0) KS = 2 KP = IABS(KPVT(K)) KPS = K + 1 - KS IF (KP .EQ. KPS) GO TO 70 T = Z(KPS) Z(KPS) = Z(KP) Z(KP) = T 70 CONTINUE IF (Z(K) .NE. 0.0E0) EK = SIGN(EK,Z(K)) Z(K) = Z(K) + EK CALL SAXPY(K-KS,Z(K),AP(IK+1),1,Z(1),1) IF (KS .EQ. 1) GO TO 80 IF (Z(K-1) .NE. 0.0E0) EK = SIGN(EK,Z(K-1)) Z(K-1) = Z(K-1) + EK CALL SAXPY(K-KS,Z(K-1),AP(IKM1+1),1,Z(1),1) 80 CONTINUE IF (KS .EQ. 2) GO TO 100 IF (ABS(Z(K)) .LE. ABS(AP(KK))) GO TO 90 S = ABS(AP(KK))/ABS(Z(K)) CALL SSCAL(N,S,Z,1) EK = S*EK 90 CONTINUE IF (AP(KK) .NE. 0.0E0) Z(K) = Z(K)/AP(KK) IF (AP(KK) .EQ. 0.0E0) Z(K) = 1.0E0 GO TO 110 100 CONTINUE KM1K = IK + K - 1 KM1KM1 = IKM1 + K - 1 AK = AP(KK)/AP(KM1K) AKM1 = AP(KM1KM1)/AP(KM1K) BK = Z(K)/AP(KM1K) BKM1 = Z(K-1)/AP(KM1K) DENOM = AK*AKM1 - 1.0E0 Z(K) = (AKM1*BK - BKM1)/DENOM Z(K-1) = (AK*BKM1 - BK)/DENOM 110 CONTINUE K = K - KS IK = IK - K IF (KS .EQ. 2) IK = IK - (K + 1) GO TO 60 120 CONTINUE S = 1.0E0/SASUM(N,Z,1) CALL SSCAL(N,S,Z,1) C C SOLVE TRANS(U)*Y = W C K = 1 IK = 0 130 IF (K .GT. N) GO TO 160 KS = 1 IF (KPVT(K) .LT. 0) KS = 2 IF (K .EQ. 1) GO TO 150 Z(K) = Z(K) + SDOT(K-1,AP(IK+1),1,Z(1),1) IKP1 = IK + K IF (KS .EQ. 2) * Z(K+1) = Z(K+1) + SDOT(K-1,AP(IKP1+1),1,Z(1),1) KP = IABS(KPVT(K)) IF (KP .EQ. K) GO TO 140 T = Z(K) Z(K) = Z(KP) Z(KP) = T 140 CONTINUE 150 CONTINUE IK = IK + K IF (KS .EQ. 2) IK = IK + (K + 1) K = K + KS GO TO 130 160 CONTINUE S = 1.0E0/SASUM(N,Z,1) CALL SSCAL(N,S,Z,1) C YNORM = 1.0E0 C C SOLVE U*D*V = Y C K = N IK = N*(N - 1)/2 170 IF (K .EQ. 0) GO TO 230 KK = IK + K IKM1 = IK - (K - 1) KS = 1 IF (KPVT(K) .LT. 0) KS = 2 IF (K .EQ. KS) GO TO 190 KP = IABS(KPVT(K)) KPS = K + 1 - KS IF (KP .EQ. KPS) GO TO 180 T = Z(KPS) Z(KPS) = Z(KP) Z(KP) = T 180 CONTINUE CALL SAXPY(K-KS,Z(K),AP(IK+1),1,Z(1),1) IF (KS .EQ. 2) CALL SAXPY(K-KS,Z(K-1),AP(IKM1+1),1,Z(1),1) 190 CONTINUE IF (KS .EQ. 2) GO TO 210 IF (ABS(Z(K)) .LE. ABS(AP(KK))) GO TO 200 S = ABS(AP(KK))/ABS(Z(K)) CALL SSCAL(N,S,Z,1) YNORM = S*YNORM 200 CONTINUE IF (AP(KK) .NE. 0.0E0) Z(K) = Z(K)/AP(KK) IF (AP(KK) .EQ. 0.0E0) Z(K) = 1.0E0 GO TO 220 210 CONTINUE KM1K = IK + K - 1 KM1KM1 = IKM1 + K - 1 AK = AP(KK)/AP(KM1K) AKM1 = AP(KM1KM1)/AP(KM1K) BK = Z(K)/AP(KM1K) BKM1 = Z(K-1)/AP(KM1K) DENOM = AK*AKM1 - 1.0E0 Z(K) = (AKM1*BK - BKM1)/DENOM Z(K-1) = (AK*BKM1 - BK)/DENOM 220 CONTINUE K = K - KS IK = IK - K IF (KS .EQ. 2) IK = IK - (K + 1) GO TO 170 230 CONTINUE S = 1.0E0/SASUM(N,Z,1) CALL SSCAL(N,S,Z,1) YNORM = S*YNORM C C SOLVE TRANS(U)*Z = V C K = 1 IK = 0 240 IF (K .GT. N) GO TO 270 KS = 1 IF (KPVT(K) .LT. 0) KS = 2 IF (K .EQ. 1) GO TO 260 Z(K) = Z(K) + SDOT(K-1,AP(IK+1),1,Z(1),1) IKP1 = IK + K IF (KS .EQ. 2) * Z(K+1) = Z(K+1) + SDOT(K-1,AP(IKP1+1),1,Z(1),1) KP = IABS(KPVT(K)) IF (KP .EQ. K) GO TO 250 T = Z(K) Z(K) = Z(KP) Z(KP) = T 250 CONTINUE 260 CONTINUE IK = IK + K IF (KS .EQ. 2) IK = IK + (K + 1) K = K + KS GO TO 240 270 CONTINUE C MAKE ZNORM = 1.0 S = 1.0E0/SASUM(N,Z,1) CALL SSCAL(N,S,Z,1) YNORM = S*YNORM C IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0 RETURN END SUBROUTINE SSPFA(AP,N,KPVT,INFO) INTEGER N,KPVT(*),INFO REAL AP(*) C C SSPFA FACTORS A REAL SYMMETRIC MATRIX STORED IN C PACKED FORM BY ELIMINATION WITH SYMMETRIC PIVOTING. C C TO SOLVE A*X = B , FOLLOW SSPFA BY SSPSL. C TO COMPUTE INVERSE(A)*C , FOLLOW SSPFA BY SSPSL. C TO COMPUTE DETERMINANT(A) , FOLLOW SSPFA BY SSPDI. C TO COMPUTE INERTIA(A) , FOLLOW SSPFA BY SSPDI. C TO COMPUTE INVERSE(A) , FOLLOW SSPFA BY SSPDI. C C ON ENTRY C C AP REAL (N*(N+1)/2) C THE PACKED FORM OF A SYMMETRIC MATRIX A . THE C COLUMNS OF THE UPPER TRIANGLE ARE STORED SEQUENTIALLY C IN A ONE-DIMENSIONAL ARRAY OF LENGTH N*(N+1)/2 . C SEE COMMENTS BELOW FOR DETAILS. C C N INTEGER C THE ORDER OF THE MATRIX A . C C OUTPUT C C AP A BLOCK DIAGONAL MATRIX AND THE MULTIPLIERS WHICH C WERE USED TO OBTAIN IT STORED IN PACKED FORM. C THE FACTORIZATION CAN BE WRITTEN A = U*D*TRANS(U) C WHERE U IS A PRODUCT OF PERMUTATION AND UNIT C UPPER TRIANGULAR MATRICES , TRANS(U) IS THE C TRANSPOSE OF U , AND D IS BLOCK DIAGONAL C WITH 1 BY 1 AND 2 BY 2 BLOCKS. C C KPVT INTEGER(N) C AN INTEGER VECTOR OF PIVOT INDICES. C C INFO INTEGER C = 0 NORMAL VALUE. C = K IF THE K-TH PIVOT BLOCK IS SINGULAR. THIS IS C NOT AN ERROR CONDITION FOR THIS SUBROUTINE, C BUT IT DOES INDICATE THAT SSPSL OR SSPDI MAY C DIVIDE BY ZERO IF CALLED. C C PACKED STORAGE C C THE FOLLOWING PROGRAM SEGMENT WILL PACK THE UPPER C TRIANGLE OF A SYMMETRIC MATRIX. C C K = 0 C DO 20 J = 1, N C DO 10 I = 1, J C K = K + 1 C AP(K) = A(I,J) C 10 CONTINUE C 20 CONTINUE C C LINPACK. THIS VERSION DATED 08/14/78 . C JAMES BUNCH, UNIV. CALIF. SAN DIEGO, ARGONNE NAT. LAB. C C SUBROUTINES AND FUNCTIONS C C BLAS SAXPY,SSWAP,ISAMAX C FORTRAN ABS,AMAX1,SQRT C C INTERNAL VARIABLES C REAL AK,AKM1,BK,BKM1,DENOM,MULK,MULKM1,T REAL ABSAKK,ALPHA,COLMAX,ROWMAX INTEGER ISAMAX,IJ,IJJ,IK,IKM1,IM,IMAX,IMAXP1,IMIM,IMJ,IMK INTEGER J,JJ,JK,JKM1,JMAX,JMIM,K,KK,KM1,KM1K,KM1KM1,KM2,KSTEP LOGICAL SWAP C C C INITIALIZE C C ALPHA IS USED IN CHOOSING PIVOT BLOCK SIZE. ALPHA = (1.0E0 + SQRT(17.0E0))/8.0E0 C INFO = 0 C C MAIN LOOP ON K, WHICH GOES FROM N TO 1. C K = N IK = (N*(N - 1))/2 10 CONTINUE C C LEAVE THE LOOP IF K=0 OR K=1. C C ...EXIT IF (K .EQ. 0) GO TO 200 IF (K .GT. 1) GO TO 20 KPVT(1) = 1 IF (AP(1) .EQ. 0.0E0) INFO = 1 C ......EXIT GO TO 200 20 CONTINUE C C THIS SECTION OF CODE DETERMINES THE KIND OF C ELIMINATION TO BE PERFORMED. WHEN IT IS COMPLETED, C KSTEP WILL BE SET TO THE SIZE OF THE PIVOT BLOCK, AND C SWAP WILL BE SET TO .TRUE. IF AN INTERCHANGE IS C REQUIRED. C KM1 = K - 1 KK = IK + K ABSAKK = ABS(AP(KK)) C C DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN C COLUMN K. C IMAX = ISAMAX(K-1,AP(IK+1),1) IMK = IK + IMAX COLMAX = ABS(AP(IMK)) IF (ABSAKK .LT. ALPHA*COLMAX) GO TO 30 KSTEP = 1 SWAP = .FALSE. GO TO 90 30 CONTINUE C C DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN C ROW IMAX. C ROWMAX = 0.0E0 IMAXP1 = IMAX + 1 IM = IMAX*(IMAX - 1)/2 IMJ = IM + 2*IMAX DO 40 J = IMAXP1, K ROWMAX = AMAX1(ROWMAX,ABS(AP(IMJ))) IMJ = IMJ + J 40 CONTINUE IF (IMAX .EQ. 1) GO TO 50 JMAX = ISAMAX(IMAX-1,AP(IM+1),1) JMIM = JMAX + IM ROWMAX = AMAX1(ROWMAX,ABS(AP(JMIM))) 50 CONTINUE IMIM = IMAX + IM IF (ABS(AP(IMIM)) .LT. ALPHA*ROWMAX) GO TO 60 KSTEP = 1 SWAP = .TRUE. GO TO 80 60 CONTINUE IF (ABSAKK .LT. ALPHA*COLMAX*(COLMAX/ROWMAX)) GO TO 70 KSTEP = 1 SWAP = .FALSE. GO TO 80 70 CONTINUE KSTEP = 2 SWAP = IMAX .NE. KM1 80 CONTINUE 90 CONTINUE IF (AMAX1(ABSAKK,COLMAX) .NE. 0.0E0) GO TO 100 C C COLUMN K IS ZERO. SET INFO AND ITERATE THE LOOP. C KPVT(K) = K INFO = K GO TO 190 100 CONTINUE IF (KSTEP .EQ. 2) GO TO 140 C C 1 X 1 PIVOT BLOCK. C IF (.NOT.SWAP) GO TO 120 C C PERFORM AN INTERCHANGE. C CALL SSWAP(IMAX,AP(IM+1),1,AP(IK+1),1) IMJ = IK + IMAX DO 110 JJ = IMAX, K J = K + IMAX - JJ JK = IK + J T = AP(JK) AP(JK) = AP(IMJ) AP(IMJ) = T IMJ = IMJ - (J - 1) 110 CONTINUE 120 CONTINUE C C PERFORM THE ELIMINATION. C IJ = IK - (K - 1) DO 130 JJ = 1, KM1 J = K - JJ JK = IK + J MULK = -AP(JK)/AP(KK) T = MULK CALL SAXPY(J,T,AP(IK+1),1,AP(IJ+1),1) IJJ = IJ + J AP(JK) = MULK IJ = IJ - (J - 1) 130 CONTINUE C C SET THE PIVOT ARRAY. C KPVT(K) = K IF (SWAP) KPVT(K) = IMAX GO TO 190 140 CONTINUE C C 2 X 2 PIVOT BLOCK. C KM1K = IK + K - 1 IKM1 = IK - (K - 1) IF (.NOT.SWAP) GO TO 160 C C PERFORM AN INTERCHANGE. C CALL SSWAP(IMAX,AP(IM+1),1,AP(IKM1+1),1) IMJ = IKM1 + IMAX DO 150 JJ = IMAX, KM1 J = KM1 + IMAX - JJ JKM1 = IKM1 + J T = AP(JKM1) AP(JKM1) = AP(IMJ) AP(IMJ) = T IMJ = IMJ - (J - 1) 150 CONTINUE T = AP(KM1K) AP(KM1K) = AP(IMK) AP(IMK) = T 160 CONTINUE C C PERFORM THE ELIMINATION. C KM2 = K - 2 IF (KM2 .EQ. 0) GO TO 180 AK = AP(KK)/AP(KM1K) KM1KM1 = IKM1 + K - 1 AKM1 = AP(KM1KM1)/AP(KM1K) DENOM = 1.0E0 - AK*AKM1 IJ = IK - (K - 1) - (K - 2) DO 170 JJ = 1, KM2 J = KM1 - JJ JK = IK + J BK = AP(JK)/AP(KM1K) JKM1 = IKM1 + J BKM1 = AP(JKM1)/AP(KM1K) MULK = (AKM1*BK - BKM1)/DENOM MULKM1 = (AK*BKM1 - BK)/DENOM T = MULK CALL SAXPY(J,T,AP(IK+1),1,AP(IJ+1),1) T = MULKM1 CALL SAXPY(J,T,AP(IKM1+1),1,AP(IJ+1),1) AP(JK) = MULK AP(JKM1) = MULKM1 IJJ = IJ + J IJ = IJ - (J - 1) 170 CONTINUE 180 CONTINUE C C SET THE PIVOT ARRAY. C KPVT(K) = 1 - K IF (SWAP) KPVT(K) = -IMAX KPVT(K-1) = KPVT(K) 190 CONTINUE IK = IK - (K - 1) IF (KSTEP .EQ. 2) IK = IK - (K - 2) K = K - KSTEP GO TO 10 200 CONTINUE RETURN END SUBROUTINE SSPSL(AP,N,KPVT,B) INTEGER N,KPVT(*) REAL AP(*),B(*) C C SSISL SOLVES THE REAL SYMMETRIC SYSTEM C A * X = B C USING THE FACTORS COMPUTED BY SSPFA. C C ON ENTRY C C AP REAL(N*(N+1)/2) C THE OUTPUT FROM SSPFA. C C N INTEGER C THE ORDER OF THE MATRIX A . C C KPVT INTEGER(N) C THE PIVOT VECTOR FROM SSPFA. C C B REAL(N) C THE RIGHT HAND SIDE VECTOR. C C ON RETURN C C B THE SOLUTION VECTOR X . C C ERROR CONDITION C C A DIVISION BY ZERO MAY OCCUR IF SSPCO HAS SET RCOND .EQ. 0.0 C OR SSPFA HAS SET INFO .NE. 0 . C C TO COMPUTE INVERSE(A) * C WHERE C IS A MATRIX C WITH P COLUMNS C CALL SSPFA(AP,N,KPVT,INFO) C IF (INFO .NE. 0) GO TO ... C DO 10 J = 1, P C CALL SSPSL(AP,N,KPVT,C(1,J)) C 10 CONTINUE C C LINPACK. THIS VERSION DATED 08/14/78 . C JAMES BUNCH, UNIV. CALIF. SAN DIEGO, ARGONNE NAT. LAB. C C SUBROUTINES AND FUNCTIONS C C BLAS SAXPY,SDOT C FORTRAN IABS C C INTERNAL VARIABLES. C REAL AK,AKM1,BK,BKM1,SDOT,DENOM,TEMP INTEGER IK,IKM1,IKP1,K,KK,KM1K,KM1KM1,KP C C LOOP BACKWARD APPLYING THE TRANSFORMATIONS AND C D INVERSE TO B. C K = N IK = (N*(N - 1))/2 10 IF (K .EQ. 0) GO TO 80 KK = IK + K IF (KPVT(K) .LT. 0) GO TO 40 C C 1 X 1 PIVOT BLOCK. C IF (K .EQ. 1) GO TO 30 KP = KPVT(K) IF (KP .EQ. K) GO TO 20 C C INTERCHANGE. C TEMP = B(K) B(K) = B(KP) B(KP) = TEMP 20 CONTINUE C C APPLY THE TRANSFORMATION. C CALL SAXPY(K-1,B(K),AP(IK+1),1,B(1),1) 30 CONTINUE C C APPLY D INVERSE. C B(K) = B(K)/AP(KK) K = K - 1 IK = IK - K GO TO 70 40 CONTINUE C C 2 X 2 PIVOT BLOCK. C IKM1 = IK - (K - 1) IF (K .EQ. 2) GO TO 60 KP = IABS(KPVT(K)) IF (KP .EQ. K - 1) GO TO 50 C C INTERCHANGE. C TEMP = B(K-1) B(K-1) = B(KP) B(KP) = TEMP 50 CONTINUE C C APPLY THE TRANSFORMATION. C CALL SAXPY(K-2,B(K),AP(IK+1),1,B(1),1) CALL SAXPY(K-2,B(K-1),AP(IKM1+1),1,B(1),1) 60 CONTINUE C C APPLY D INVERSE. C KM1K = IK + K - 1 KK = IK + K AK = AP(KK)/AP(KM1K) KM1KM1 = IKM1 + K - 1 AKM1 = AP(KM1KM1)/AP(KM1K) BK = B(K)/AP(KM1K) BKM1 = B(K-1)/AP(KM1K) DENOM = AK*AKM1 - 1.0E0 B(K) = (AKM1*BK - BKM1)/DENOM B(K-1) = (AK*BKM1 - BK)/DENOM K = K - 2 IK = IK - (K + 1) - K 70 CONTINUE GO TO 10 80 CONTINUE C C LOOP FORWARD APPLYING THE TRANSFORMATIONS. C K = 1 IK = 0 90 IF (K .GT. N) GO TO 160 IF (KPVT(K) .LT. 0) GO TO 120 C C 1 X 1 PIVOT BLOCK. C IF (K .EQ. 1) GO TO 110 C C APPLY THE TRANSFORMATION. C B(K) = B(K) + SDOT(K-1,AP(IK+1),1,B(1),1) KP = KPVT(K) IF (KP .EQ. K) GO TO 100 C C INTERCHANGE. C TEMP = B(K) B(K) = B(KP) B(KP) = TEMP 100 CONTINUE 110 CONTINUE IK = IK + K K = K + 1 GO TO 150 120 CONTINUE C C 2 X 2 PIVOT BLOCK. C IF (K .EQ. 1) GO TO 140 C C APPLY THE TRANSFORMATION. C B(K) = B(K) + SDOT(K-1,AP(IK+1),1,B(1),1) IKP1 = IK + K B(K+1) = B(K+1) + SDOT(K-1,AP(IKP1+1),1,B(1),1) KP = IABS(KPVT(K)) IF (KP .EQ. K) GO TO 130 C C INTERCHANGE. C TEMP = B(K) B(K) = B(KP) B(KP) = TEMP 130 CONTINUE 140 CONTINUE IK = IK + K + K + 1 K = K + 2 150 CONTINUE GO TO 90 160 CONTINUE RETURN END SUBROUTINE SSPDI(AP,N,KPVT,DET,INERT,WORK,JOB) INTEGER N,JOB REAL AP(*),WORK(*) REAL DET(2) INTEGER KPVT(*),INERT(3) C C SSPDI COMPUTES THE DETERMINANT, INERTIA AND INVERSE C OF A REAL SYMMETRIC MATRIX USING THE FACTORS FROM SSPFA, C WHERE THE MATRIX IS STORED IN PACKED FORM. C C ON ENTRY C C AP REAL (N*(N+1)/2) C THE OUTPUT FROM SSPFA. C C N INTEGER C THE ORDER OF THE MATRIX A. C C KPVT INTEGER(N) C THE PIVOT VECTOR FROM SSPFA. C C WORK REAL(N) C WORK VECTOR. CONTENTS IGNORED. C C JOB INTEGER C JOB HAS THE DECIMAL EXPANSION ABC WHERE C IF C .NE. 0, THE INVERSE IS COMPUTED, C IF B .NE. 0, THE DETERMINANT IS COMPUTED, C IF A .NE. 0, THE INERTIA IS COMPUTED. C C FOR EXAMPLE, JOB = 111 GIVES ALL THREE. C C ON RETURN C C VARIABLES NOT REQUESTED BY JOB ARE NOT USED. C C AP CONTAINS THE UPPER TRIANGLE OF THE INVERSE OF C THE ORIGINAL MATRIX, STORED IN PACKED FORM. C THE COLUMNS OF THE UPPER TRIANGLE ARE STORED C SEQUENTIALLY IN A ONE-DIMENSIONAL ARRAY. C C DET REAL(2) C DETERMINANT OF ORIGINAL MATRIX. C DETERMINANT = DET(1) * 10.0**DET(2) C WITH 1.0 .LE. ABS(DET(1)) .LT. 10.0 C OR DET(1) = 0.0. C C INERT INTEGER(3) C THE INERTIA OF THE ORIGINAL MATRIX. C INERT(1) = NUMBER OF POSITIVE EIGENVALUES. C INERT(2) = NUMBER OF NEGATIVE EIGENVALUES. C INERT(3) = NUMBER OF ZERO EIGENVALUES. C C ERROR CONDITION C C A DIVISION BY ZERO WILL OCCUR IF THE INVERSE IS REQUESTED C AND SSPCO HAS SET RCOND .EQ. 0.0 C OR SSPFA HAS SET INFO .NE. 0 . C C LINPACK. THIS VERSION DATED 08/14/78 . C JAMES BUNCH, UNIV. CALIF. SAN DIEGO, ARGONNE NAT. LAB. C C SUBROUTINES AND FUNCTIONS C C BLAS SAXPY,SCOPY,SDOT,SSWAP C FORTRAN ABS,IABS,MOD C C INTERNAL VARIABLES. C REAL AKKP1,SDOT,TEMP REAL TEN,D,T,AK,AKP1 INTEGER IJ,IK,IKP1,IKS,J,JB,JK,JKP1 INTEGER K,KK,KKP1,KM1,KS,KSJ,KSKP1,KSTEP LOGICAL NOINV,NODET,NOERT C NOINV = MOD(JOB,10) .EQ. 0 NODET = MOD(JOB,100)/10 .EQ. 0 NOERT = MOD(JOB,1000)/100 .EQ. 0 C IF (NODET .AND. NOERT) GO TO 140 IF (NOERT) GO TO 10 INERT(1) = 0 INERT(2) = 0 INERT(3) = 0 10 CONTINUE IF (NODET) GO TO 20 DET(1) = 1.0E0 DET(2) = 0.0E0 TEN = 10.0E0 20 CONTINUE T = 0.0E0 IK = 0 DO 130 K = 1, N KK = IK + K D = AP(KK) C C CHECK IF 1 BY 1 C IF (KPVT(K) .GT. 0) GO TO 50 C C 2 BY 2 BLOCK C USE DET (D S) = (D/T * C - T) * T , T = ABS(S) C (S C) C TO AVOID UNDERFLOW/OVERFLOW TROUBLES. C TAKE TWO PASSES THROUGH SCALING. USE T FOR FLAG. C IF (T .NE. 0.0E0) GO TO 30 IKP1 = IK + K KKP1 = IKP1 + K T = ABS(AP(KKP1)) D = (D/T)*AP(KKP1+1) - T GO TO 40 30 CONTINUE D = T T = 0.0E0 40 CONTINUE 50 CONTINUE C IF (NOERT) GO TO 60 IF (D .GT. 0.0E0) INERT(1) = INERT(1) + 1 IF (D .LT. 0.0E0) INERT(2) = INERT(2) + 1 IF (D .EQ. 0.0E0) INERT(3) = INERT(3) + 1 60 CONTINUE C IF (NODET) GO TO 120 DET(1) = D*DET(1) IF (DET(1) .EQ. 0.0E0) GO TO 110 70 IF (ABS(DET(1)) .GE. 1.0E0) GO TO 80 DET(1) = TEN*DET(1) DET(2) = DET(2) - 1.0E0 GO TO 70 80 CONTINUE 90 IF (ABS(DET(1)) .LT. TEN) GO TO 100 DET(1) = DET(1)/TEN DET(2) = DET(2) + 1.0E0 GO TO 90 100 CONTINUE 110 CONTINUE 120 CONTINUE IK = IK + K 130 CONTINUE 140 CONTINUE C C COMPUTE INVERSE(A) C IF (NOINV) GO TO 270 K = 1 IK = 0 150 IF (K .GT. N) GO TO 260 KM1 = K - 1 KK = IK + K IKP1 = IK + K KKP1 = IKP1 + K IF (KPVT(K) .LT. 0) GO TO 180 C C 1 BY 1 C AP(KK) = 1.0E0/AP(KK) IF (KM1 .LT. 1) GO TO 170 CALL SCOPY(KM1,AP(IK+1),1,WORK,1) IJ = 0 DO 160 J = 1, KM1 JK = IK + J AP(JK) = SDOT(J,AP(IJ+1),1,WORK,1) CALL SAXPY(J-1,WORK(J),AP(IJ+1),1,AP(IK+1),1) IJ = IJ + J 160 CONTINUE AP(KK) = AP(KK) + SDOT(KM1,WORK,1,AP(IK+1),1) 170 CONTINUE KSTEP = 1 GO TO 220 180 CONTINUE C C 2 BY 2 C T = ABS(AP(KKP1)) AK = AP(KK)/T AKP1 = AP(KKP1+1)/T AKKP1 = AP(KKP1)/T D = T*(AK*AKP1 - 1.0E0) AP(KK) = AKP1/D AP(KKP1+1) = AK/D AP(KKP1) = -AKKP1/D IF (KM1 .LT. 1) GO TO 210 CALL SCOPY(KM1,AP(IKP1+1),1,WORK,1) IJ = 0 DO 190 J = 1, KM1 JKP1 = IKP1 + J AP(JKP1) = SDOT(J,AP(IJ+1),1,WORK,1) CALL SAXPY(J-1,WORK(J),AP(IJ+1),1,AP(IKP1+1),1) IJ = IJ + J 190 CONTINUE AP(KKP1+1) = AP(KKP1+1) * + SDOT(KM1,WORK,1,AP(IKP1+1),1) AP(KKP1) = AP(KKP1) * + SDOT(KM1,AP(IK+1),1,AP(IKP1+1),1) CALL SCOPY(KM1,AP(IK+1),1,WORK,1) IJ = 0 DO 200 J = 1, KM1 JK = IK + J AP(JK) = SDOT(J,AP(IJ+1),1,WORK,1) CALL SAXPY(J-1,WORK(J),AP(IJ+1),1,AP(IK+1),1) IJ = IJ + J 200 CONTINUE AP(KK) = AP(KK) + SDOT(KM1,WORK,1,AP(IK+1),1) 210 CONTINUE KSTEP = 2 220 CONTINUE C C SWAP C KS = IABS(KPVT(K)) IF (KS .EQ. K) GO TO 250 IKS = (KS*(KS - 1))/2 CALL SSWAP(KS,AP(IKS+1),1,AP(IK+1),1) KSJ = IK + KS DO 230 JB = KS, K J = K + KS - JB JK = IK + J TEMP = AP(JK) AP(JK) = AP(KSJ) AP(KSJ) = TEMP KSJ = KSJ - (J - 1) 230 CONTINUE IF (KSTEP .EQ. 1) GO TO 240 KSKP1 = IKP1 + KS TEMP = AP(KSKP1) AP(KSKP1) = AP(KKP1) AP(KKP1) = TEMP 240 CONTINUE 250 CONTINUE IK = IK + K IF (KSTEP .EQ. 2) IK = IK + K + 1 K = K + KSTEP GO TO 150 260 CONTINUE 270 CONTINUE RETURN END SUBROUTINE DSMSLV(MO,N,M,A,B,KB,DET,RCOND,INERT,IERR,IPVT,WK) C ------------------ DOUBLE PRECISION A(*),B(*) DOUBLE PRECISION DET(2),RCOND,T,WK(N) INTEGER INERT(3),IPVT(N),ONEJ C ------------------ C C MATRIX FACTORIZATION AND COMPUTATION OF RCOND C IERR = 0 CALL DSPCO(A,N,IPVT,RCOND,WK) T = 1.D0 + RCOND IF (T .EQ. 1.D0) GO TO 30 C C SOLUTION OF THE EQUATION AX=B C IF (M .LT. 1) GO TO 20 ONEJ = 1 DO 10 J=1,M CALL DSPSL(A,N,IPVT,B(ONEJ)) 10 ONEJ = ONEJ + KB C C CALCULATION OF DET AND THE INVERSE OF A C 20 JOB = 110 IF (MO .EQ. 0) JOB = 111 CALL DSPDI(A,N,IPVT,DET,INERT,WK,JOB) RETURN C C THE PROBLEM CANNOT BE SOLVED C 30 IERR = 1 RETURN END SUBROUTINE DSPCO(AP,N,KPVT,RCOND,Z) INTEGER N,KPVT(*) DOUBLE PRECISION AP(*),Z(*) DOUBLE PRECISION RCOND C C DSPCO FACTORS A DOUBLE PRECISION SYMMETRIC MATRIX STORED IN C PACKED FORM BY ELIMINATION WITH SYMMETRIC PIVOTING AND ESTIMATES C THE CONDITION OF THE MATRIX. C C IF RCOND IS NOT NEEDED, DSPFA IS SLIGHTLY FASTER. C TO SOLVE A*X = B , FOLLOW DSPCO BY DSPSL. C TO COMPUTE INVERSE(A)*C , FOLLOW DSPCO BY DSPSL. C TO COMPUTE INVERSE(A) , FOLLOW DSPCO BY DSPDI. C TO COMPUTE DETERMINANT(A) , FOLLOW DSPCO BY DSPDI. C TO COMPUTE INERTIA(A), FOLLOW DSPCO BY DSPDI. C C ON ENTRY C C AP DOUBLE PRECISION (N*(N+1)/2) C THE PACKED FORM OF A SYMMETRIC MATRIX A . THE C COLUMNS OF THE UPPER TRIANGLE ARE STORED SEQUENTIALLY C IN A ONE-DIMENSIONAL ARRAY OF LENGTH N*(N+1)/2 . C SEE COMMENTS BELOW FOR DETAILS. C C N INTEGER C THE ORDER OF THE MATRIX A . C C OUTPUT C C AP A BLOCK DIAGONAL MATRIX AND THE MULTIPLIERS WHICH C WERE USED TO OBTAIN IT STORED IN PACKED FORM. C THE FACTORIZATION CAN BE WRITTEN A = U*D*TRANS(U) C WHERE U IS A PRODUCT OF PERMUTATION AND UNIT C UPPER TRIANGULAR MATRICES , TRANS(U) IS THE C TRANSPOSE OF U , AND D IS BLOCK DIAGONAL C WITH 1 BY 1 AND 2 BY 2 BLOCKS. C C KPVT INTEGER(N) C AN INTEGER VECTOR OF PIVOT INDICES. C C RCOND DOUBLE PRECISION C AN ESTIMATE OF THE RECIPROCAL CONDITION OF A . C FOR THE SYSTEM A*X = B , RELATIVE PERTURBATIONS C IN A AND B OF SIZE EPSILON MAY CAUSE C RELATIVE PERTURBATIONS IN X OF SIZE EPSILON/RCOND . C IF RCOND IS SO SMALL THAT THE LOGICAL EXPRESSION C 1.0 + RCOND .EQ. 1.0 C IS TRUE, THEN A MAY BE SINGULAR TO WORKING C PRECISION. IN PARTICULAR, RCOND IS ZERO IF C EXACT SINGULARITY IS DETECTED OR THE ESTIMATE C UNDERFLOWS. C C Z DOUBLE PRECISION(N) C A WORK VECTOR WHOSE CONTENTS ARE USUALLY UNIMPORTANT. C IF A IS CLOSE TO A SINGULAR MATRIX, THEN Z IS C AN APPROXIMATE NULL VECTOR IN THE SENSE THAT C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . C C PACKED STORAGE C C THE FOLLOWING PROGRAM SEGMENT WILL PACK THE UPPER C TRIANGLE OF A SYMMETRIC MATRIX. C C K = 0 C DO 20 J = 1, N C DO 10 I = 1, J C K = K + 1 C AP(K) = A(I,J) C 10 CONTINUE C 20 CONTINUE C C LINPACK. THIS VERSION DATED 08/14/78 . C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. C C SUBROUTINES AND FUNCTIONS C C LINPACK DSPFA C BLAS DAXPY,DDOT,DSCAL,DASUM C FORTRAN DABS,DMAX1,IABS,DSIGN C C INTERNAL VARIABLES C DOUBLE PRECISION AK,AKM1,BK,BKM1,DDOT,DENOM,EK,T DOUBLE PRECISION ANORM,S,DASUM,YNORM INTEGER I,IJ,IK,IKM1,IKP1,INFO,J,JM1,J1 INTEGER K,KK,KM1K,KM1KM1,KP,KPS,KS C C C FIND NORM OF A USING ONLY UPPER HALF C J1 = 1 DO 30 J = 1, N Z(J) = DASUM(J,AP(J1),1) IJ = J1 J1 = J1 + J JM1 = J - 1 IF (JM1 .LT. 1) GO TO 20 DO 10 I = 1, JM1 Z(I) = Z(I) + DABS(AP(IJ)) IJ = IJ + 1 10 CONTINUE 20 CONTINUE 30 CONTINUE ANORM = 0.0D0 DO 40 J = 1, N ANORM = DMAX1(ANORM,Z(J)) 40 CONTINUE C C FACTOR C CALL DSPFA(AP,N,KPVT,INFO) C C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND A*Y = E . C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL C GROWTH IN THE ELEMENTS OF W WHERE U*D*W = E . C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. C C SOLVE U*D*W = E C EK = 1.0D0 DO 50 J = 1, N Z(J) = 0.0D0 50 CONTINUE K = N IK = (N*(N - 1))/2 60 IF (K .EQ. 0) GO TO 120 KK = IK + K IKM1 = IK - (K - 1) KS = 1 IF (KPVT(K) .LT. 0) KS = 2 KP = IABS(KPVT(K)) KPS = K + 1 - KS IF (KP .EQ. KPS) GO TO 70 T = Z(KPS) Z(KPS) = Z(KP) Z(KP) = T 70 CONTINUE IF (Z(K) .NE. 0.0D0) EK = DSIGN(EK,Z(K)) Z(K) = Z(K) + EK CALL DAXPY(K-KS,Z(K),AP(IK+1),1,Z(1),1) IF (KS .EQ. 1) GO TO 80 IF (Z(K-1) .NE. 0.0D0) EK = DSIGN(EK,Z(K-1)) Z(K-1) = Z(K-1) + EK CALL DAXPY(K-KS,Z(K-1),AP(IKM1+1),1,Z(1),1) 80 CONTINUE IF (KS .EQ. 2) GO TO 100 IF (DABS(Z(K)) .LE. DABS(AP(KK))) GO TO 90 S = DABS(AP(KK))/DABS(Z(K)) CALL DSCAL(N,S,Z,1) EK = S*EK 90 CONTINUE IF (AP(KK) .NE. 0.0D0) Z(K) = Z(K)/AP(KK) IF (AP(KK) .EQ. 0.0D0) Z(K) = 1.0D0 GO TO 110 100 CONTINUE KM1K = IK + K - 1 KM1KM1 = IKM1 + K - 1 AK = AP(KK)/AP(KM1K) AKM1 = AP(KM1KM1)/AP(KM1K) BK = Z(K)/AP(KM1K) BKM1 = Z(K-1)/AP(KM1K) DENOM = AK*AKM1 - 1.0D0 Z(K) = (AKM1*BK - BKM1)/DENOM Z(K-1) = (AK*BKM1 - BK)/DENOM 110 CONTINUE K = K - KS IK = IK - K IF (KS .EQ. 2) IK = IK - (K + 1) GO TO 60 120 CONTINUE S = 1.0D0/DASUM(N,Z,1) CALL DSCAL(N,S,Z,1) C C SOLVE TRANS(U)*Y = W C K = 1 IK = 0 130 IF (K .GT. N) GO TO 160 KS = 1 IF (KPVT(K) .LT. 0) KS = 2 IF (K .EQ. 1) GO TO 150 Z(K) = Z(K) + DDOT(K-1,AP(IK+1),1,Z(1),1) IKP1 = IK + K IF (KS .EQ. 2) * Z(K+1) = Z(K+1) + DDOT(K-1,AP(IKP1+1),1,Z(1),1) KP = IABS(KPVT(K)) IF (KP .EQ. K) GO TO 140 T = Z(K) Z(K) = Z(KP) Z(KP) = T 140 CONTINUE 150 CONTINUE IK = IK + K IF (KS .EQ. 2) IK = IK + (K + 1) K = K + KS GO TO 130 160 CONTINUE S = 1.0D0/DASUM(N,Z,1) CALL DSCAL(N,S,Z,1) C YNORM = 1.0D0 C C SOLVE U*D*V = Y C K = N IK = N*(N - 1)/2 170 IF (K .EQ. 0) GO TO 230 KK = IK + K IKM1 = IK - (K - 1) KS = 1 IF (KPVT(K) .LT. 0) KS = 2 IF (K .EQ. KS) GO TO 190 KP = IABS(KPVT(K)) KPS = K + 1 - KS IF (KP .EQ. KPS) GO TO 180 T = Z(KPS) Z(KPS) = Z(KP) Z(KP) = T 180 CONTINUE CALL DAXPY(K-KS,Z(K),AP(IK+1),1,Z(1),1) IF (KS .EQ. 2) CALL DAXPY(K-KS,Z(K-1),AP(IKM1+1),1,Z(1),1) 190 CONTINUE IF (KS .EQ. 2) GO TO 210 IF (DABS(Z(K)) .LE. DABS(AP(KK))) GO TO 200 S = DABS(AP(KK))/DABS(Z(K)) CALL DSCAL(N,S,Z,1) YNORM = S*YNORM 200 CONTINUE IF (AP(KK) .NE. 0.0D0) Z(K) = Z(K)/AP(KK) IF (AP(KK) .EQ. 0.0D0) Z(K) = 1.0D0 GO TO 220 210 CONTINUE KM1K = IK + K - 1 KM1KM1 = IKM1 + K - 1 AK = AP(KK)/AP(KM1K) AKM1 = AP(KM1KM1)/AP(KM1K) BK = Z(K)/AP(KM1K) BKM1 = Z(K-1)/AP(KM1K) DENOM = AK*AKM1 - 1.0D0 Z(K) = (AKM1*BK - BKM1)/DENOM Z(K-1) = (AK*BKM1 - BK)/DENOM 220 CONTINUE K = K - KS IK = IK - K IF (KS .EQ. 2) IK = IK - (K + 1) GO TO 170 230 CONTINUE S = 1.0D0/DASUM(N,Z,1) CALL DSCAL(N,S,Z,1) YNORM = S*YNORM C C SOLVE TRANS(U)*Z = V C K = 1 IK = 0 240 IF (K .GT. N) GO TO 270 KS = 1 IF (KPVT(K) .LT. 0) KS = 2 IF (K .EQ. 1) GO TO 260 Z(K) = Z(K) + DDOT(K-1,AP(IK+1),1,Z(1),1) IKP1 = IK + K IF (KS .EQ. 2) * Z(K+1) = Z(K+1) + DDOT(K-1,AP(IKP1+1),1,Z(1),1) KP = IABS(KPVT(K)) IF (KP .EQ. K) GO TO 250 T = Z(K) Z(K) = Z(KP) Z(KP) = T 250 CONTINUE 260 CONTINUE IK = IK + K IF (KS .EQ. 2) IK = IK + (K + 1) K = K + KS GO TO 240 270 CONTINUE C MAKE ZNORM = 1.0 S = 1.0D0/DASUM(N,Z,1) CALL DSCAL(N,S,Z,1) YNORM = S*YNORM C IF (ANORM .NE. 0.0D0) RCOND = YNORM/ANORM IF (ANORM .EQ. 0.0D0) RCOND = 0.0D0 RETURN END SUBROUTINE DSPFA(AP,N,KPVT,INFO) INTEGER N,KPVT(*),INFO DOUBLE PRECISION AP(*) C C DSPFA FACTORS A DOUBLE PRECISION SYMMETRIC MATRIX STORED IN C PACKED FORM BY ELIMINATION WITH SYMMETRIC PIVOTING. C C TO SOLVE A*X = B , FOLLOW DSPFA BY DSPSL. C TO COMPUTE INVERSE(A)*C , FOLLOW DSPFA BY DSPSL. C TO COMPUTE DETERMINANT(A) , FOLLOW DSPFA BY DSPDI. C TO COMPUTE INERTIA(A) , FOLLOW DSPFA BY DSPDI. C TO COMPUTE INVERSE(A) , FOLLOW DSPFA BY DSPDI. C C ON ENTRY C C AP DOUBLE PRECISION (N*(N+1)/2) C THE PACKED FORM OF A SYMMETRIC MATRIX A . THE C COLUMNS OF THE UPPER TRIANGLE ARE STORED SEQUENTIALLY C IN A ONE-DIMENSIONAL ARRAY OF LENGTH N*(N+1)/2 . C SEE COMMENTS BELOW FOR DETAILS. C C N INTEGER C THE ORDER OF THE MATRIX A . C C OUTPUT C C AP A BLOCK DIAGONAL MATRIX AND THE MULTIPLIERS WHICH C WERE USED TO OBTAIN IT STORED IN PACKED FORM. C THE FACTORIZATION CAN BE WRITTEN A = U*D*TRANS(U) C WHERE U IS A PRODUCT OF PERMUTATION AND UNIT C UPPER TRIANGULAR MATRICES , TRANS(U) IS THE C TRANSPOSE OF U , AND D IS BLOCK DIAGONAL C WITH 1 BY 1 AND 2 BY 2 BLOCKS. C C KPVT INTEGER(N) C AN INTEGER VECTOR OF PIVOT INDICES. C C INFO INTEGER C = 0 NORMAL VALUE. C = K IF THE K-TH PIVOT BLOCK IS SINGULAR. THIS IS C NOT AN ERROR CONDITION FOR THIS SUBROUTINE, C BUT IT DOES INDICATE THAT DSPSL OR DSPDI MAY C DIVIDE BY ZERO IF CALLED. C C PACKED STORAGE C C THE FOLLOWING PROGRAM SEGMENT WILL PACK THE UPPER C TRIANGLE OF A SYMMETRIC MATRIX. C C K = 0 C DO 20 J = 1, N C DO 10 I = 1, J C K = K + 1 C AP(K) = A(I,J) C 10 CONTINUE C 20 CONTINUE C C LINPACK. THIS VERSION DATED 08/14/78 . C JAMES BUNCH, UNIV. CALIF. SAN DIEGO, ARGONNE NAT. LAB. C C SUBROUTINES AND FUNCTIONS C C BLAS DAXPY,DSWAP,IDAMAX C FORTRAN DABS,DMAX1,DSQRT C C INTERNAL VARIABLES C DOUBLE PRECISION AK,AKM1,BK,BKM1,DENOM,MULK,MULKM1,T DOUBLE PRECISION ABSAKK,ALPHA,COLMAX,ROWMAX INTEGER IDAMAX,IJ,IJJ,IK,IKM1,IM,IMAX,IMAXP1,IMIM,IMJ,IMK INTEGER J,JJ,JK,JKM1,JMAX,JMIM,K,KK,KM1,KM1K,KM1KM1,KM2,KSTEP LOGICAL SWAP C C C INITIALIZE C C ALPHA IS USED IN CHOOSING PIVOT BLOCK SIZE. ALPHA = (1.0D0 + DSQRT(17.0D0))/8.0D0 C INFO = 0 C C MAIN LOOP ON K, WHICH GOES FROM N TO 1. C K = N IK = (N*(N - 1))/2 10 CONTINUE C C LEAVE THE LOOP IF K=0 OR K=1. C C ...EXIT IF (K .EQ. 0) GO TO 200 IF (K .GT. 1) GO TO 20 KPVT(1) = 1 IF (AP(1) .EQ. 0.0D0) INFO = 1 C ......EXIT GO TO 200 20 CONTINUE C C THIS SECTION OF CODE DETERMINES THE KIND OF C ELIMINATION TO BE PERFORMED. WHEN IT IS COMPLETED, C KSTEP WILL BE SET TO THE SIZE OF THE PIVOT BLOCK, AND C SWAP WILL BE SET TO .TRUE. IF AN INTERCHANGE IS C REQUIRED. C KM1 = K - 1 KK = IK + K ABSAKK = DABS(AP(KK)) C C DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN C COLUMN K. C IMAX = IDAMAX(K-1,AP(IK+1),1) IMK = IK + IMAX COLMAX = DABS(AP(IMK)) IF (ABSAKK .LT. ALPHA*COLMAX) GO TO 30 KSTEP = 1 SWAP = .FALSE. GO TO 90 30 CONTINUE C C DETERMINE THE LARGEST OFF-DIAGONAL ELEMENT IN C ROW IMAX. C ROWMAX = 0.0D0 IMAXP1 = IMAX + 1 IM = IMAX*(IMAX - 1)/2 IMJ = IM + 2*IMAX DO 40 J = IMAXP1, K ROWMAX = DMAX1(ROWMAX,DABS(AP(IMJ))) IMJ = IMJ + J 40 CONTINUE IF (IMAX .EQ. 1) GO TO 50 JMAX = IDAMAX(IMAX-1,AP(IM+1),1) JMIM = JMAX + IM ROWMAX = DMAX1(ROWMAX,DABS(AP(JMIM))) 50 CONTINUE IMIM = IMAX + IM IF (DABS(AP(IMIM)) .LT. ALPHA*ROWMAX) GO TO 60 KSTEP = 1 SWAP = .TRUE. GO TO 80 60 CONTINUE IF (ABSAKK .LT. ALPHA*COLMAX*(COLMAX/ROWMAX)) GO TO 70 KSTEP = 1 SWAP = .FALSE. GO TO 80 70 CONTINUE KSTEP = 2 SWAP = IMAX .NE. KM1 80 CONTINUE 90 CONTINUE IF (DMAX1(ABSAKK,COLMAX) .NE. 0.0D0) GO TO 100 C C COLUMN K IS ZERO. SET INFO AND ITERATE THE LOOP. C KPVT(K) = K INFO = K GO TO 190 100 CONTINUE IF (KSTEP .EQ. 2) GO TO 140 C C 1 X 1 PIVOT BLOCK. C IF (.NOT.SWAP) GO TO 120 C C PERFORM AN INTERCHANGE. C CALL DSWAP(IMAX,AP(IM+1),1,AP(IK+1),1) IMJ = IK + IMAX DO 110 JJ = IMAX, K J = K + IMAX - JJ JK = IK + J T = AP(JK) AP(JK) = AP(IMJ) AP(IMJ) = T IMJ = IMJ - (J - 1) 110 CONTINUE 120 CONTINUE C C PERFORM THE ELIMINATION. C IJ = IK - (K - 1) DO 130 JJ = 1, KM1 J = K - JJ JK = IK + J MULK = -AP(JK)/AP(KK) T = MULK CALL DAXPY(J,T,AP(IK+1),1,AP(IJ+1),1) IJJ = IJ + J AP(JK) = MULK IJ = IJ - (J - 1) 130 CONTINUE C C SET THE PIVOT ARRAY. C KPVT(K) = K IF (SWAP) KPVT(K) = IMAX GO TO 190 140 CONTINUE C C 2 X 2 PIVOT BLOCK. C KM1K = IK + K - 1 IKM1 = IK - (K - 1) IF (.NOT.SWAP) GO TO 160 C C PERFORM AN INTERCHANGE. C CALL DSWAP(IMAX,AP(IM+1),1,AP(IKM1+1),1) IMJ = IKM1 + IMAX DO 150 JJ = IMAX, KM1 J = KM1 + IMAX - JJ JKM1 = IKM1 + J T = AP(JKM1) AP(JKM1) = AP(IMJ) AP(IMJ) = T IMJ = IMJ - (J - 1) 150 CONTINUE T = AP(KM1K) AP(KM1K) = AP(IMK) AP(IMK) = T 160 CONTINUE C C PERFORM THE ELIMINATION. C KM2 = K - 2 IF (KM2 .EQ. 0) GO TO 180 AK = AP(KK)/AP(KM1K) KM1KM1 = IKM1 + K - 1 AKM1 = AP(KM1KM1)/AP(KM1K) DENOM = 1.0D0 - AK*AKM1 IJ = IK - (K - 1) - (K - 2) DO 170 JJ = 1, KM2 J = KM1 - JJ JK = IK + J BK = AP(JK)/AP(KM1K) JKM1 = IKM1 + J BKM1 = AP(JKM1)/AP(KM1K) MULK = (AKM1*BK - BKM1)/DENOM MULKM1 = (AK*BKM1 - BK)/DENOM T = MULK CALL DAXPY(J,T,AP(IK+1),1,AP(IJ+1),1) T = MULKM1 CALL DAXPY(J,T,AP(IKM1+1),1,AP(IJ+1),1) AP(JK) = MULK AP(JKM1) = MULKM1 IJJ = IJ + J IJ = IJ - (J - 1) 170 CONTINUE 180 CONTINUE C C SET THE PIVOT ARRAY. C KPVT(K) = 1 - K IF (SWAP) KPVT(K) = -IMAX KPVT(K-1) = KPVT(K) 190 CONTINUE IK = IK - (K - 1) IF (KSTEP .EQ. 2) IK = IK - (K - 2) K = K - KSTEP GO TO 10 200 CONTINUE RETURN END SUBROUTINE DSPSL(AP,N,KPVT,B) INTEGER N,KPVT(*) DOUBLE PRECISION AP(*),B(*) C C DSISL SOLVES THE DOUBLE PRECISION SYMMETRIC SYSTEM C A * X = B C USING THE FACTORS COMPUTED BY DSPFA. C C ON ENTRY C C AP DOUBLE PRECISION(N*(N+1)/2) C THE OUTPUT FROM DSPFA. C C N INTEGER C THE ORDER OF THE MATRIX A . C C KPVT INTEGER(N) C THE PIVOT VECTOR FROM DSPFA. C C B DOUBLE PRECISION(N) C THE RIGHT HAND SIDE VECTOR. C C ON RETURN C C B THE SOLUTION VECTOR X . C C ERROR CONDITION C C A DIVISION BY ZERO MAY OCCUR IF DSPCO HAS SET RCOND .EQ. 0.0 C OR DSPFA HAS SET INFO .NE. 0 . C C TO COMPUTE INVERSE(A) * C WHERE C IS A MATRIX C WITH P COLUMNS C CALL DSPFA(AP,N,KPVT,INFO) C IF (INFO .NE. 0) GO TO ... C DO 10 J = 1, P C CALL DSPSL(AP,N,KPVT,C(1,J)) C 10 CONTINUE C C LINPACK. THIS VERSION DATED 08/14/78 . C JAMES BUNCH, UNIV. CALIF. SAN DIEGO, ARGONNE NAT. LAB. C C SUBROUTINES AND FUNCTIONS C C BLAS DAXPY,DDOT C FORTRAN IABS C C INTERNAL VARIABLES. C DOUBLE PRECISION AK,AKM1,BK,BKM1,DDOT,DENOM,TEMP INTEGER IK,IKM1,IKP1,K,KK,KM1K,KM1KM1,KP C C LOOP BACKWARD APPLYING THE TRANSFORMATIONS AND C D INVERSE TO B. C K = N IK = (N*(N - 1))/2 10 IF (K .EQ. 0) GO TO 80 KK = IK + K IF (KPVT(K) .LT. 0) GO TO 40 C C 1 X 1 PIVOT BLOCK. C IF (K .EQ. 1) GO TO 30 KP = KPVT(K) IF (KP .EQ. K) GO TO 20 C C INTERCHANGE. C TEMP = B(K) B(K) = B(KP) B(KP) = TEMP 20 CONTINUE C C APPLY THE TRANSFORMATION. C CALL DAXPY(K-1,B(K),AP(IK+1),1,B(1),1) 30 CONTINUE C C APPLY D INVERSE. C B(K) = B(K)/AP(KK) K = K - 1 IK = IK - K GO TO 70 40 CONTINUE C C 2 X 2 PIVOT BLOCK. C IKM1 = IK - (K - 1) IF (K .EQ. 2) GO TO 60 KP = IABS(KPVT(K)) IF (KP .EQ. K - 1) GO TO 50 C C INTERCHANGE. C TEMP = B(K-1) B(K-1) = B(KP) B(KP) = TEMP 50 CONTINUE C C APPLY THE TRANSFORMATION. C CALL DAXPY(K-2,B(K),AP(IK+1),1,B(1),1) CALL DAXPY(K-2,B(K-1),AP(IKM1+1),1,B(1),1) 60 CONTINUE C C APPLY D INVERSE. C KM1K = IK + K - 1 KK = IK + K AK = AP(KK)/AP(KM1K) KM1KM1 = IKM1 + K - 1 AKM1 = AP(KM1KM1)/AP(KM1K) BK = B(K)/AP(KM1K) BKM1 = B(K-1)/AP(KM1K) DENOM = AK*AKM1 - 1.0D0 B(K) = (AKM1*BK - BKM1)/DENOM B(K-1) = (AK*BKM1 - BK)/DENOM K = K - 2 IK = IK - (K + 1) - K 70 CONTINUE GO TO 10 80 CONTINUE C C LOOP FORWARD APPLYING THE TRANSFORMATIONS. C K = 1 IK = 0 90 IF (K .GT. N) GO TO 160 IF (KPVT(K) .LT. 0) GO TO 120 C C 1 X 1 PIVOT BLOCK. C IF (K .EQ. 1) GO TO 110 C C APPLY THE TRANSFORMATION. C B(K) = B(K) + DDOT(K-1,AP(IK+1),1,B(1),1) KP = KPVT(K) IF (KP .EQ. K) GO TO 100 C C INTERCHANGE. C TEMP = B(K) B(K) = B(KP) B(KP) = TEMP 100 CONTINUE 110 CONTINUE IK = IK + K K = K + 1 GO TO 150 120 CONTINUE C C 2 X 2 PIVOT BLOCK. C IF (K .EQ. 1) GO TO 140 C C APPLY THE TRANSFORMATION. C B(K) = B(K) + DDOT(K-1,AP(IK+1),1,B(1),1) IKP1 = IK + K B(K+1) = B(K+1) + DDOT(K-1,AP(IKP1+1),1,B(1),1) KP = IABS(KPVT(K)) IF (KP .EQ. K) GO TO 130 C C INTERCHANGE. C TEMP = B(K) B(K) = B(KP) B(KP) = TEMP 130 CONTINUE 140 CONTINUE IK = IK + K + K + 1 K = K + 2 150 CONTINUE GO TO 90 160 CONTINUE RETURN END SUBROUTINE DSPDI(AP,N,KPVT,DET,INERT,WORK,JOB) INTEGER N,JOB DOUBLE PRECISION AP(*),WORK(*) DOUBLE PRECISION DET(2) INTEGER KPVT(*),INERT(3) C C DSPDI COMPUTES THE DETERMINANT, INERTIA AND INVERSE C OF A DOUBLE PRECISION SYMMETRIC MATRIX USING THE FACTORS FROM C DSPFA, WHERE THE MATRIX IS STORED IN PACKED FORM. C C ON ENTRY C C AP DOUBLE PRECISION (N*(N+1)/2) C THE OUTPUT FROM DSPFA. C C N INTEGER C THE ORDER OF THE MATRIX A. C C KPVT INTEGER(N) C THE PIVOT VECTOR FROM DSPFA. C C WORK DOUBLE PRECISION(N) C WORK VECTOR. CONTENTS IGNORED. C C JOB INTEGER C JOB HAS THE DECIMAL EXPANSION ABC WHERE C IF C .NE. 0, THE INVERSE IS COMPUTED, C IF B .NE. 0, THE DETERMINANT IS COMPUTED, C IF A .NE. 0, THE INERTIA IS COMPUTED. C C FOR EXAMPLE, JOB = 111 GIVES ALL THREE. C C ON RETURN C C VARIABLES NOT REQUESTED BY JOB ARE NOT USED. C C AP CONTAINS THE UPPER TRIANGLE OF THE INVERSE OF C THE ORIGINAL MATRIX, STORED IN PACKED FORM. C THE COLUMNS OF THE UPPER TRIANGLE ARE STORED C SEQUENTIALLY IN A ONE-DIMENSIONAL ARRAY. C C DET DOUBLE PRECISION(2) C DETERMINANT OF ORIGINAL MATRIX. C DETERMINANT = DET(1) * 10.0**DET(2) C WITH 1.0 .LE. DABS(DET(1)) .LT. 10.0 C OR DET(1) = 0.0. C C INERT INTEGER(3) C THE INERTIA OF THE ORIGINAL MATRIX. C INERT(1) = NUMBER OF POSITIVE EIGENVALUES. C INERT(2) = NUMBER OF NEGATIVE EIGENVALUES. C INERT(3) = NUMBER OF ZERO EIGENVALUES. C C ERROR CONDITION C C A DIVISION BY ZERO WILL OCCUR IF THE INVERSE IS REQUESTED C AND DSPCO HAS SET RCOND .EQ. 0.0 C OR DSPFA HAS SET INFO .NE. 0 . C C LINPACK. THIS VERSION DATED 08/14/78 . C JAMES BUNCH, UNIV. CALIF. SAN DIEGO, ARGONNE NAT. LAB. C C SUBROUTINES AND FUNCTIONS C C BLAS DAXPY,DCOPY,DDOT,DSWAP C FORTRAN DABS,IABS,MOD C C INTERNAL VARIABLES. C DOUBLE PRECISION AKKP1,DDOT,TEMP DOUBLE PRECISION TEN,D,T,AK,AKP1 INTEGER IJ,IK,IKP1,IKS,J,JB,JK,JKP1 INTEGER K,KK,KKP1,KM1,KS,KSJ,KSKP1,KSTEP LOGICAL NOINV,NODET,NOERT C NOINV = MOD(JOB,10) .EQ. 0 NODET = MOD(JOB,100)/10 .EQ. 0 NOERT = MOD(JOB,1000)/100 .EQ. 0 C IF (NODET .AND. NOERT) GO TO 140 IF (NOERT) GO TO 10 INERT(1) = 0 INERT(2) = 0 INERT(3) = 0 10 CONTINUE IF (NODET) GO TO 20 DET(1) = 1.0D0 DET(2) = 0.0D0 TEN = 10.0D0 20 CONTINUE T = 0.0D0 IK = 0 DO 130 K = 1, N KK = IK + K D = AP(KK) C C CHECK IF 1 BY 1 C IF (KPVT(K) .GT. 0) GO TO 50 C C 2 BY 2 BLOCK C USE DET (D S) = (D/T * C - T) * T , T = DABS(S) C (S C) C TO AVOID UNDERFLOW/OVERFLOW TROUBLES. C TAKE TWO PASSES THROUGH SCALING. USE T FOR FLAG. C IF (T .NE. 0.0D0) GO TO 30 IKP1 = IK + K KKP1 = IKP1 + K T = DABS(AP(KKP1)) D = (D/T)*AP(KKP1+1) - T GO TO 40 30 CONTINUE D = T T = 0.0D0 40 CONTINUE 50 CONTINUE C IF (NOERT) GO TO 60 IF (D .GT. 0.0D0) INERT(1) = INERT(1) + 1 IF (D .LT. 0.0D0) INERT(2) = INERT(2) + 1 IF (D .EQ. 0.0D0) INERT(3) = INERT(3) + 1 60 CONTINUE C IF (NODET) GO TO 120 DET(1) = D*DET(1) IF (DET(1) .EQ. 0.0D0) GO TO 110 70 IF (DABS(DET(1)) .GE. 1.0D0) GO TO 80 DET(1) = TEN*DET(1) DET(2) = DET(2) - 1.0D0 GO TO 70 80 CONTINUE 90 IF (DABS(DET(1)) .LT. TEN) GO TO 100 DET(1) = DET(1)/TEN DET(2) = DET(2) + 1.0D0 GO TO 90 100 CONTINUE 110 CONTINUE 120 CONTINUE IK = IK + K 130 CONTINUE 140 CONTINUE C C COMPUTE INVERSE(A) C IF (NOINV) GO TO 270 K = 1 IK = 0 150 IF (K .GT. N) GO TO 260 KM1 = K - 1 KK = IK + K IKP1 = IK + K KKP1 = IKP1 + K IF (KPVT(K) .LT. 0) GO TO 180 C C 1 BY 1 C AP(KK) = 1.0D0/AP(KK) IF (KM1 .LT. 1) GO TO 170 CALL DCOPY(KM1,AP(IK+1),1,WORK,1) IJ = 0 DO 160 J = 1, KM1 JK = IK + J AP(JK) = DDOT(J,AP(IJ+1),1,WORK,1) CALL DAXPY(J-1,WORK(J),AP(IJ+1),1,AP(IK+1),1) IJ = IJ + J 160 CONTINUE AP(KK) = AP(KK) + DDOT(KM1,WORK,1,AP(IK+1),1) 170 CONTINUE KSTEP = 1 GO TO 220 180 CONTINUE C C 2 BY 2 C T = DABS(AP(KKP1)) AK = AP(KK)/T AKP1 = AP(KKP1+1)/T AKKP1 = AP(KKP1)/T D = T*(AK*AKP1 - 1.0D0) AP(KK) = AKP1/D AP(KKP1+1) = AK/D AP(KKP1) = -AKKP1/D IF (KM1 .LT. 1) GO TO 210 CALL DCOPY(KM1,AP(IKP1+1),1,WORK,1) IJ = 0 DO 190 J = 1, KM1 JKP1 = IKP1 + J AP(JKP1) = DDOT(J,AP(IJ+1),1,WORK,1) CALL DAXPY(J-1,WORK(J),AP(IJ+1),1,AP(IKP1+1),1) IJ = IJ + J 190 CONTINUE AP(KKP1+1) = AP(KKP1+1) * + DDOT(KM1,WORK,1,AP(IKP1+1),1) AP(KKP1) = AP(KKP1) * + DDOT(KM1,AP(IK+1),1,AP(IKP1+1),1) CALL DCOPY(KM1,AP(IK+1),1,WORK,1) IJ = 0 DO 200 J = 1, KM1 JK = IK + J AP(JK) = DDOT(J,AP(IJ+1),1,WORK,1) CALL DAXPY(J-1,WORK(J),AP(IJ+1),1,AP(IK+1),1) IJ = IJ + J 200 CONTINUE AP(KK) = AP(KK) + DDOT(KM1,WORK,1,AP(IK+1),1) 210 CONTINUE KSTEP = 2 220 CONTINUE C C SWAP C KS = IABS(KPVT(K)) IF (KS .EQ. K) GO TO 250 IKS = (KS*(KS - 1))/2 CALL DSWAP(KS,AP(IKS+1),1,AP(IK+1),1) KSJ = IK + KS DO 230 JB = KS, K J = K + KS - JB JK = IK + J TEMP = AP(JK) AP(JK) = AP(KSJ) AP(KSJ) = TEMP KSJ = KSJ - (J - 1) 230 CONTINUE IF (KSTEP .EQ. 1) GO TO 240 KSKP1 = IKP1 + KS TEMP = AP(KSKP1) AP(KSKP1) = AP(KKP1) AP(KKP1) = TEMP 240 CONTINUE 250 CONTINUE IK = IK + K IF (KSTEP .EQ. 2) IK = IK + K + 1 K = K + KSTEP GO TO 150 260 CONTINUE 270 CONTINUE RETURN END SUBROUTINE PCHOL (MO,N,M,A,B,KB,IERR) C ----------------- REAL A(*), B(*), D(2) INTEGER ONEJ C ----------------- C C MATRIX FACTORIZATION C CALL SPPFA (A,N,IERR) IF (IERR .NE. 0) RETURN C C SOLUTION OF THE EQUATION AX=B C IF (M .LT. 1) GO TO 20 ONEJ = 1 DO 10 J = 1,M CALL SPPSL (A,N,B(ONEJ)) 10 ONEJ = ONEJ + KB C C COMPUTATION OF THE INVERSE OF A C 20 IF (MO .EQ. 0) CALL SPPDI (A,N,D,1) RETURN END SUBROUTINE SPPFA(AP,N,INFO) INTEGER N,INFO REAL AP(*) C C SPPFA FACTORS A REAL SYMMETRIC POSITIVE DEFINITE MATRIX C STORED IN PACKED FORM. C C SPPFA IS USUALLY CALLED BY SPPCO, BUT IT CAN BE CALLED C DIRECTLY WITH A SAVING IN TIME IF RCOND IS NOT NEEDED. C (TIME FOR SPPCO) = (1 + 18/N)*(TIME FOR SPPFA) . C C ON ENTRY C C AP REAL (N*(N+1)/2) C THE PACKED FORM OF A SYMMETRIC MATRIX A . THE C COLUMNS OF THE UPPER TRIANGLE ARE STORED SEQUENTIALLY C IN A ONE-DIMENSIONAL ARRAY OF LENGTH N*(N+1)/2 . C SEE COMMENTS BELOW FOR DETAILS. C C N INTEGER C THE ORDER OF THE MATRIX A . C C ON RETURN C C AP AN UPPER TRIANGULAR MATRIX R , STORED IN PACKED C FORM, SO THAT A = TRANS(R)*R . C C INFO INTEGER C = 0 FOR NORMAL RETURN. C = K IF THE LEADING MINOR OF ORDER K IS NOT C POSITIVE DEFINITE. C C C PACKED STORAGE C C THE FOLLOWING PROGRAM SEGMENT WILL PACK THE UPPER C TRIANGLE OF A SYMMETRIC MATRIX. C C K = 0 C DO 20 J = 1, N C DO 10 I = 1, J C K = K + 1 C AP(K) = A(I,J) C 10 CONTINUE C 20 CONTINUE C C LINPACK. THIS VERSION DATED 08/14/78 . C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. C C SUBROUTINES AND FUNCTIONS C C BLAS SDOT C FORTRAN SQRT C C INTERNAL VARIABLES C REAL SDOT,T REAL S INTEGER J,JJ,JM1,K,KJ,KK C BEGIN BLOCK WITH ...EXITS TO 40 C C JJ = 0 DO 30 J = 1, N INFO = J S = 0.0E0 JM1 = J - 1 KJ = JJ KK = 0 IF (JM1 .LT. 1) GO TO 20 DO 10 K = 1, JM1 KJ = KJ + 1 T = AP(KJ) - SDOT(K-1,AP(KK+1),1,AP(JJ+1),1) KK = KK + K T = T/AP(KK) AP(KJ) = T S = S + T*T 10 CONTINUE 20 CONTINUE JJ = JJ + J S = AP(JJ) - S C ......EXIT IF (S .LE. 0.0E0) GO TO 40 AP(JJ) = SQRT(S) 30 CONTINUE INFO = 0 40 CONTINUE RETURN END SUBROUTINE SPPSL(AP,N,B) INTEGER N REAL AP(*),B(*) C C SPPSL SOLVES THE REAL SYMMETRIC POSITIVE DEFINITE SYSTEM C A * X = B C USING THE FACTORS COMPUTED BY SPPCO OR SPPFA. C C ON ENTRY C C AP REAL (N*(N+1)/2) C THE OUTPUT FROM SPPCO OR SPPFA. C C N INTEGER C THE ORDER OF THE MATRIX A . C C B REAL(N) C THE RIGHT HAND SIDE VECTOR. C C ON RETURN C C B THE SOLUTION VECTOR X . C C ERROR CONDITION C C A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS C A ZERO ON THE DIAGONAL. TECHNICALLY THIS INDICATES C SINGULARITY BUT IT IS USUALLY CAUSED BY IMPROPER SUBROUTINE C ARGUMENTS. IT WILL NOT OCCUR IF THE SUBROUTINES ARE CALLED C CORRECTLY AND INFO .EQ. 0 . C C TO COMPUTE INVERSE(A) * C WHERE C IS A MATRIX C WITH P COLUMNS C CALL SPPCO(AP,N,RCOND,Z,INFO) C IF (RCOND IS TOO SMALL .OR. INFO .NE. 0) GO TO ... C DO 10 J = 1, P C CALL SPPSL(AP,N,C(1,J)) C 10 CONTINUE C C LINPACK. THIS VERSION DATED 08/14/78 . C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. C C SUBROUTINES AND FUNCTIONS C C BLAS SAXPY,SDOT C C INTERNAL VARIABLES C REAL SDOT,T INTEGER K,KB,KK C KK = 0 DO 10 K = 1, N T = SDOT(K-1,AP(KK+1),1,B(1),1) KK = KK + K B(K) = (B(K) - T)/AP(KK) 10 CONTINUE DO 20 KB = 1, N K = N + 1 - KB B(K) = B(K)/AP(KK) KK = KK - K T = -B(K) CALL SAXPY(K-1,T,AP(KK+1),1,B(1),1) 20 CONTINUE RETURN END SUBROUTINE SPPDI(AP,N,DET,JOB) INTEGER N,JOB REAL AP(*) REAL DET(2) C C SPPDI COMPUTES THE DETERMINANT AND INVERSE C OF A REAL SYMMETRIC POSITIVE DEFINITE MATRIX C USING THE FACTORS COMPUTED BY SPPCO OR SPPFA . C C ON ENTRY C C AP REAL (N*(N+1)/2) C THE OUTPUT FROM SPPCO OR SPPFA. C C N INTEGER C THE ORDER OF THE MATRIX A . C C JOB INTEGER C = 11 BOTH DETERMINANT AND INVERSE. C = 01 INVERSE ONLY. C = 10 DETERMINANT ONLY. C C ON RETURN C C AP THE UPPER TRIANGULAR HALF OF THE INVERSE . C C DET REAL(2) C DETERMINANT OF ORIGINAL MATRIX IF REQUESTED. C OTHERWISE NOT REFERENCED. C DETERMINANT = DET(1) * 10.0**DET(2) C WITH 1.0 .LE. DET(1) .LT. 10.0 C OR DET(1) .EQ. 0.0 . C C ERROR CONDITION C C A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS C A ZERO ON THE DIAGONAL AND THE INVERSE IS REQUESTED. C IT WILL NOT OCCUR IF THE SUBROUTINES ARE CALLED CORRECTLY C AND IF SPOCO OR SPOFA HAS SET INFO .EQ. 0 . C C LINPACK. THIS VERSION DATED 08/14/78 . C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. C C SUBROUTINES AND FUNCTIONS C C BLAS SAXPY,SSCAL C FORTRAN MOD C C INTERNAL VARIABLES C REAL T REAL S INTEGER I,II,J,JJ,JM1,J1,K,KJ,KK,KP1,K1 C C COMPUTE DETERMINANT C IF (JOB/10 .EQ. 0) GO TO 70 DET(1) = 1.0E0 DET(2) = 0.0E0 S = 10.0E0 II = 0 DO 50 I = 1, N II = II + I DET(1) = AP(II)**2*DET(1) C ...EXIT IF (DET(1) .EQ. 0.0E0) GO TO 60 10 IF (DET(1) .GE. 1.0E0) GO TO 20 DET(1) = S*DET(1) DET(2) = DET(2) - 1.0E0 GO TO 10 20 CONTINUE 30 IF (DET(1) .LT. S) GO TO 40 DET(1) = DET(1)/S DET(2) = DET(2) + 1.0E0 GO TO 30 40 CONTINUE 50 CONTINUE 60 CONTINUE 70 CONTINUE C C COMPUTE INVERSE(R) C IF (MOD(JOB,10) .EQ. 0) GO TO 140 KK = 0 DO 100 K = 1, N K1 = KK + 1 KK = KK + K AP(KK) = 1.0E0/AP(KK) T = -AP(KK) CALL SSCAL(K-1,T,AP(K1),1) KP1 = K + 1 J1 = KK + 1 KJ = KK + K IF (N .LT. KP1) GO TO 90 DO 80 J = KP1, N T = AP(KJ) AP(KJ) = 0.0E0 CALL SAXPY(K,T,AP(K1),1,AP(J1),1) J1 = J1 + J KJ = KJ + J 80 CONTINUE 90 CONTINUE 100 CONTINUE C C FORM INVERSE(R) * TRANS(INVERSE(R)) C JJ = 0 DO 130 J = 1, N J1 = JJ + 1 JJ = JJ + J JM1 = J - 1 K1 = 1 KJ = J1 IF (JM1 .LT. 1) GO TO 120 DO 110 K = 1, JM1 T = AP(KJ) CALL SAXPY(K,T,AP(J1),1,AP(K1),1) K1 = K1 + K KJ = KJ + 1 110 CONTINUE 120 CONTINUE T = AP(JJ) CALL SSCAL(J,T,AP(J1),1) 130 CONTINUE 140 CONTINUE RETURN END SUBROUTINE DPCHOL (MO,N,M,A,B,KB,IERR) C ----------------- DOUBLE PRECISION A(*), B(*), D(2) INTEGER ONEJ C ----------------- C C MATRIX FACTORIZATION C CALL DPPFA (A,N,IERR) IF (IERR .NE. 0) RETURN C C SOLUTION OF THE EQUATION AX=B C IF (M .LT. 1) GO TO 20 ONEJ = 1 DO 10 J = 1,M CALL DPPSL (A,N,B(ONEJ)) 10 ONEJ = ONEJ + KB C C COMPUTATION OF THE INVERSE OF A C 20 IF (MO .EQ. 0) CALL DPPDI (A,N,D,1) RETURN END SUBROUTINE DPPFA(AP,N,INFO) INTEGER N,INFO DOUBLE PRECISION AP(*) C C DPPFA FACTORS A DOUBLE PRECISION SYMMETRIC POSITIVE DEFINITE C MATRIX STORED IN PACKED FORM. C C DPPFA IS USUALLY CALLED BY DPPCO, BUT IT CAN BE CALLED C DIRECTLY WITH A SAVING IN TIME IF RCOND IS NOT NEEDED. C (TIME FOR DPPCO) = (1 + 18/N)*(TIME FOR DPPFA) . C C ON ENTRY C C AP DOUBLE PRECISION (N*(N+1)/2) C THE PACKED FORM OF A SYMMETRIC MATRIX A . THE C COLUMNS OF THE UPPER TRIANGLE ARE STORED SEQUENTIALLY C IN A ONE-DIMENSIONAL ARRAY OF LENGTH N*(N+1)/2 . C SEE COMMENTS BELOW FOR DETAILS. C C N INTEGER C THE ORDER OF THE MATRIX A . C C ON RETURN C C AP AN UPPER TRIANGULAR MATRIX R , STORED IN PACKED C FORM, SO THAT A = TRANS(R)*R . C C INFO INTEGER C = 0 FOR NORMAL RETURN. C = K IF THE LEADING MINOR OF ORDER K IS NOT C POSITIVE DEFINITE. C C C PACKED STORAGE C C THE FOLLOWING PROGRAM SEGMENT WILL PACK THE UPPER C TRIANGLE OF A SYMMETRIC MATRIX. C C K = 0 C DO 20 J = 1, N C DO 10 I = 1, J C K = K + 1 C AP(K) = A(I,J) C 10 CONTINUE C 20 CONTINUE C C LINPACK. THIS VERSION DATED 08/14/78 . C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. C C SUBROUTINES AND FUNCTIONS C C BLAS DDOT C FORTRAN DSQRT C C INTERNAL VARIABLES C DOUBLE PRECISION DDOT,T DOUBLE PRECISION S INTEGER J,JJ,JM1,K,KJ,KK C BEGIN BLOCK WITH ...EXITS TO 40 C C JJ = 0 DO 30 J = 1, N INFO = J S = 0.0D0 JM1 = J - 1 KJ = JJ KK = 0 IF (JM1 .LT. 1) GO TO 20 DO 10 K = 1, JM1 KJ = KJ + 1 T = AP(KJ) - DDOT(K-1,AP(KK+1),1,AP(JJ+1),1) KK = KK + K T = T/AP(KK) AP(KJ) = T S = S + T*T 10 CONTINUE 20 CONTINUE JJ = JJ + J S = AP(JJ) - S C ......EXIT IF (S .LE. 0.0D0) GO TO 40 AP(JJ) = DSQRT(S) 30 CONTINUE INFO = 0 40 CONTINUE RETURN END SUBROUTINE DPPSL(AP,N,B) INTEGER N DOUBLE PRECISION AP(*),B(*) C C DPPSL SOLVES THE DOUBLE PRECISION SYMMETRIC POSITIVE DEFINITE C SYSTEM A * X = B C USING THE FACTORS COMPUTED BY DPPCO OR DPPFA. C C ON ENTRY C C AP DOUBLE PRECISION (N*(N+1)/2) C THE OUTPUT FROM DPPCO OR DPPFA. C C N INTEGER C THE ORDER OF THE MATRIX A . C C B DOUBLE PRECISION(N) C THE RIGHT HAND SIDE VECTOR. C C ON RETURN C C B THE SOLUTION VECTOR X . C C ERROR CONDITION C C A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS C A ZERO ON THE DIAGONAL. TECHNICALLY THIS INDICATES C SINGULARITY BUT IT IS USUALLY CAUSED BY IMPROPER SUBROUTINE C ARGUMENTS. IT WILL NOT OCCUR IF THE SUBROUTINES ARE CALLED C CORRECTLY AND INFO .EQ. 0 . C C TO COMPUTE INVERSE(A) * C WHERE C IS A MATRIX C WITH P COLUMNS C CALL DPPCO(AP,N,RCOND,Z,INFO) C IF (RCOND IS TOO SMALL .OR. INFO .NE. 0) GO TO ... C DO 10 J = 1, P C CALL DPPSL(AP,N,C(1,J)) C 10 CONTINUE C C LINPACK. THIS VERSION DATED 08/14/78 . C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. C C SUBROUTINES AND FUNCTIONS C C BLAS DAXPY,DDOT C C INTERNAL VARIABLES C DOUBLE PRECISION DDOT,T INTEGER K,KB,KK C KK = 0 DO 10 K = 1, N T = DDOT(K-1,AP(KK+1),1,B(1),1) KK = KK + K B(K) = (B(K) - T)/AP(KK) 10 CONTINUE DO 20 KB = 1, N K = N + 1 - KB B(K) = B(K)/AP(KK) KK = KK - K T = -B(K) CALL DAXPY(K-1,T,AP(KK+1),1,B(1),1) 20 CONTINUE RETURN END SUBROUTINE DPPDI(AP,N,DET,JOB) INTEGER N,JOB DOUBLE PRECISION AP(*) DOUBLE PRECISION DET(2) C C DPPDI COMPUTES THE DETERMINANT AND INVERSE C OF A DOUBLE PRECISION SYMMETRIC POSITIVE DEFINITE MATRIX C USING THE FACTORS COMPUTED BY DPPCO OR DPPFA . C C ON ENTRY C C AP DOUBLE PRECISION (N*(N+1)/2) C THE OUTPUT FROM DPPCO OR DPPFA. C C N INTEGER C THE ORDER OF THE MATRIX A . C C JOB INTEGER C = 11 BOTH DETERMINANT AND INVERSE. C = 01 INVERSE ONLY. C = 10 DETERMINANT ONLY. C C ON RETURN C C AP THE UPPER TRIANGULAR HALF OF THE INVERSE . C C DET DOUBLE PRECISION(2) C DETERMINANT OF ORIGINAL MATRIX IF REQUESTED. C OTHERWISE NOT REFERENCED. C DETERMINANT = DET(1) * 10.0**DET(2) C WITH 1.0 .LE. DET(1) .LT. 10.0 C OR DET(1) .EQ. 0.0 . C C ERROR CONDITION C C A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS C A ZERO ON THE DIAGONAL AND THE INVERSE IS REQUESTED. C IT WILL NOT OCCUR IF THE SUBROUTINES ARE CALLED CORRECTLY C AND IF DPOCO OR DPOFA HAS SET INFO .EQ. 0 . C C LINPACK. THIS VERSION DATED 08/14/78 . C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. C C SUBROUTINES AND FUNCTIONS C C BLAS DAXPY,DSCAL C FORTRAN MOD C C INTERNAL VARIABLES C DOUBLE PRECISION T DOUBLE PRECISION S INTEGER I,II,J,JJ,JM1,J1,K,KJ,KK,KP1,K1 C C COMPUTE DETERMINANT C IF (JOB/10 .EQ. 0) GO TO 70 DET(1) = 1.0D0 DET(2) = 0.0D0 S = 10.0D0 II = 0 DO 50 I = 1, N II = II + I DET(1) = AP(II)**2*DET(1) C ...EXIT IF (DET(1) .EQ. 0.0D0) GO TO 60 10 IF (DET(1) .GE. 1.0D0) GO TO 20 DET(1) = S*DET(1) DET(2) = DET(2) - 1.0D0 GO TO 10 20 CONTINUE 30 IF (DET(1) .LT. S) GO TO 40 DET(1) = DET(1)/S DET(2) = DET(2) + 1.0D0 GO TO 30 40 CONTINUE 50 CONTINUE 60 CONTINUE 70 CONTINUE C C COMPUTE INVERSE(R) C IF (MOD(JOB,10) .EQ. 0) GO TO 140 KK = 0 DO 100 K = 1, N K1 = KK + 1 KK = KK + K AP(KK) = 1.0D0/AP(KK) T = -AP(KK) CALL DSCAL(K-1,T,AP(K1),1) KP1 = K + 1 J1 = KK + 1 KJ = KK + K IF (N .LT. KP1) GO TO 90 DO 80 J = KP1, N T = AP(KJ) AP(KJ) = 0.0D0 CALL DAXPY(K,T,AP(K1),1,AP(J1),1) J1 = J1 + J KJ = KJ + J 80 CONTINUE 90 CONTINUE 100 CONTINUE C C FORM INVERSE(R) * TRANS(INVERSE(R)) C JJ = 0 DO 130 J = 1, N J1 = JJ + 1 JJ = JJ + J JM1 = J - 1 K1 = 1 KJ = J1 IF (JM1 .LT. 1) GO TO 120 DO 110 K = 1, JM1 T = AP(KJ) CALL DAXPY(K,T,AP(J1),1,AP(K1),1) K1 = K1 + K KJ = KJ + 1 110 CONTINUE 120 CONTINUE T = AP(JJ) CALL DSCAL(J,T,AP(J1),1) 130 CONTINUE 140 CONTINUE RETURN END SUBROUTINE TOPLX (A, B, X, N, G, H, IERR) C----------------------------------------------------------------------- C SOLUTION OF THE TOEPLITZ SYSTEM OF EQUATIONS C C SUM(J = 1,...,N) A(N+I-J)*X(J) = B(I) C C FOR I = 1,...,N. C----------------------------------------------------------------------- C REAL A(2*N - 1) C---------------------- REAL A(*), B(N), X(N), G(N), H(N) C IF (A(N) .EQ. 0.0) GO TO 100 IERR = 0 X(1) = B(1)/A(N) IF (N .EQ. 1) RETURN G(1) = A(N - 1)/A(N) H(1) = A(N + 1)/A(N) MP1 = 1 C C COMPUTE NUMERATOR AND DENOMINATOR OF X(M+1) C 10 M = MP1 MP1 = M + 1 XN = -B(MP1) XD = -A(N) DO 20 J = 1,M L = MP1 - J NPL = N + L XN = XN + A(NPL)*X(J) 20 XD = XD + A(NPL)*G(L) IF (XD .EQ. 0.0) GO TO 100 X(MP1) = XN/XD C C COMPUTE X C C = X(MP1) DO 30 J = 1,M L = MP1 - J 30 X(J) = X(J) - C*G(L) IF (MP1 .EQ. N) RETURN C C COMPUTE NUMERATOR AND DENOMINATOR OF G(M+1) AND H(M+1) C L = N - MP1 GN = -A(L) GD = -A(N) L = N + MP1 HN = -A(L) DO 40 J = 1,M L = MP1 - J NML = N - L NPL = N + L GN = GN + A(NML)*G(J) GD = GD + A(NML)*H(L) 40 HN = HN + A(NPL)*H(J) IF (GD .EQ. 0.0) GO TO 100 G(MP1) = GN/GD H(MP1) = HN/XD C C COMPUTE G AND H C C1 = G(MP1) C2 = H(MP1) MAX = MP1/2 K = M DO 50 J = 1,MAX GJ = G(J) GK = G(K) HJ = H(J) HK = H(K) G(J) = GJ - C1*HK G(K) = GK - C1*HJ H(J) = HJ - C2*GK H(K) = HK - C2*GJ 50 K = K - 1 GO TO 10 C C ERROR RETURN C 100 IERR = 1 RETURN END SUBROUTINE DTOPLX (A, B, X, N, G, H, IERR) C----------------------------------------------------------------------- C SOLUTION OF THE TOEPLITZ SYSTEM OF EQUATIONS C C SUM(J = 1,...,N) A(N+I-J)*X(J) = B(I) C C FOR I = 1,...,N. C----------------------------------------------------------------------- C DOUBLE PRECISION A(2*N - 1) C---------------------- DOUBLE PRECISION A(*), B(N), X(N), G(N), H(N) DOUBLE PRECISION C, C1, C2, GD, GJ, GK, GN, HJ, HK, HN, XD, XN C IF (A(N) .EQ. 0.D0) GO TO 100 IERR = 0 X(1) = B(1)/A(N) IF (N .EQ. 1) RETURN G(1) = A(N - 1)/A(N) H(1) = A(N + 1)/A(N) MP1 = 1 C C COMPUTE NUMERATOR AND DENOMINATOR OF X(M+1) C 10 M = MP1 MP1 = M + 1 XN = -B(MP1) XD = -A(N) DO 20 J = 1,M L = MP1 - J NPL = N + L XN = XN + A(NPL)*X(J) 20 XD = XD + A(NPL)*G(L) IF (XD .EQ. 0.D0) GO TO 100 X(MP1) = XN/XD C C COMPUTE X C C = X(MP1) DO 30 J = 1,M L = MP1 - J 30 X(J) = X(J) - C*G(L) IF (MP1 .EQ. N) RETURN C C COMPUTE NUMERATOR AND DENOMINATOR OF G(M+1) AND H(M+1) C L = N - MP1 GN = -A(L) GD = -A(N) L = N + MP1 HN = -A(L) DO 40 J = 1,M L = MP1 - J NML = N - L NPL = N + L GN = GN + A(NML)*G(J) GD = GD + A(NML)*H(L) 40 HN = HN + A(NPL)*H(J) IF (GD .EQ. 0.D0) GO TO 100 G(MP1) = GN/GD H(MP1) = HN/XD C C COMPUTE G AND H C C1 = G(MP1) C2 = H(MP1) MAX = MP1/2 K = M DO 50 J = 1,MAX GJ = G(J) GK = G(K) HJ = H(J) HK = H(K) G(J) = GJ - C1*HK G(K) = GK - C1*HJ H(J) = HJ - C2*GK H(K) = HK - C2*GJ 50 K = K - 1 GO TO 10 C C ERROR RETURN C 100 IERR = 1 RETURN END SUBROUTINE CMSLV(MO,N,M,A,KA,B,KB,DET,RCOND,IERR,IPVT,WK) C----------------------------------------------------------------------- C PARTIAL PIVOT GAUSS PROCEDURE FOR INVERTING COMPLEX MATRICES C AND SOLVING COMPLEX EQUATIONS C----------------------------------------------------------------------- COMPLEX A(KA,N), B(*), DET(2), WK(N) REAL RCOND, T INTEGER IPVT(N), ONEJ C C MATRIX FACTORIZATION AND COMPUTATION OF RCOND C IERR = 0 CALL CGECO (A, KA, N, IPVT, RCOND, WK) T = 1.0 + RCOND IF (T .EQ. 1.0) GO TO 30 C C SOLUTION OF THE EQUATION AX=B C IF (M .LT. 1) GO TO 20 ONEJ = 1 DO 10 J = 1,M CALL CGESL (A, KA, N, IPVT, B(ONEJ), 0) ONEJ = ONEJ + KB 10 CONTINUE C C CALCULATION OF DET AND THE INVERSE OF A C 20 JOB = 10 IF (MO .EQ. 0) JOB = 11 CALL CGEDI (A, KA, N, IPVT, DET, WK, JOB) RETURN C C THE PROBLEM CANNOT BE SOLVED C 30 IERR = 1 RETURN END SUBROUTINE CMSLV1 (MO, N, M, A, KA, B, KB, IERR, IPVT, WK) C----------------------------------------------------------------------- C PARTIAL PIVOT GAUSS PROCEDURE FOR INVERTING COMPLEX MATRICES C AND SOLVING COMPLEX EQUATIONS C----------------------------------------------------------------------- COMPLEX A(KA,N), B(*), WK(*) INTEGER IPVT(N) COMPLEX D(2) INTEGER ONEJ C IF (N .LT. 1 .OR. KA .LT. N) GO TO 40 IF (M .LE. 0) GO TO 10 IF (KB .LT. N) GO TO 40 C C MATRIX FACTORIZATION C 10 CALL CGEFA (A, KA, N, IPVT, IERR) IF (IERR .NE. 0) RETURN C C SOLUTION OF THE EQUATION AX = B C IF (M .LE. 0) GO TO 30 ONEJ = 1 DO 20 J = 1,M CALL CGESL (A, KA, N, IPVT, B(ONEJ), 0) ONEJ = ONEJ + KB 20 CONTINUE C C CALCULATION OF THE INVERSE OF A C 30 IF (MO .EQ. 0) CALL CGEDI (A, KA, N, IPVT, D, WK, 1) RETURN C C ERROR RETURN C 40 IERR = -1 RETURN END SUBROUTINE CSLVMP(MO, N, A, KA, B, X, WK, IWK, IERR) C ****************************************************************** C SOLUTION OF COMPLEX LINEAR EQUATIONS WITH ITERATIVE IMPROVEMENT C ****************************************************************** COMPLEX A(KA,N), B(N), X(N), WK(*) INTEGER IWK(N) C ----------------- C COMPLEX WK(N*N + N) C ----------------- IF (MO .NE. 0) GO TO 10 C C COMPUTE THE LU DECOMPOSITION OF A C CALL CMCOPY(N, N, A, KA, WK, N) CALL CGEFA(WK, N, N, IWK, IERR) IF (IERR .EQ. 0) GO TO 10 IERR = -IERR RETURN C C SOLVE THE SYSTEM OF EQUATIONS AX = B C 10 DO 11 I = 1,N 11 X(I) = B(I) C IR = N*N + 1 CALL CGESL(WK, N, N, IWK, X, 0) CALL CLUIMP(A, KA, N, WK(1), N, IWK, B, X, WK(IR), IERR) RETURN END SUBROUTINE CLUIMP(A, KA, N, Q, KQ, IPVT, B, X, R, IND) C ---------------------------------------------------------------------- C PURPOSE C GIVEN AN APPROXIMATE SOLUTION X OF A COMPLEX SYSTEM AX = B C OBTAINED USING CGECO OR CGEFA. CLUIMP ATTEMPTS TO COMPUTE C AN IMPROVED SOLUTION CORRECT TO MACHINE PRECISION. C C PARAMETERS C C A A COMPLEX ARRAY OF DIMENSION (KA,N) CONTAINING THE C MATRIX A OF ORDER N. C Q A COMPLEX ARRAY OF DIMENSION (KQ,N) CONTAINING THE C LU DECOMPOSITION OF A PRODUCED BY CGECO OR CGEFA. C IPVT AN ARRAY OF DIMENSION N CONTAINING THE PERMUTATION C INFORMATION GIVEN BY CGECO OR CGEFA. C B THE RIGHT HAND SIDE OF THE EQUATION AX = B. C X ON INPUT X IS THE APPROXIMATE SOLUTION OF AX = B TO C BE IMPROVED. ON OUTPUT X IS THE SOLUTION OBTAINED. C R A COMPLEX ARRAY FOR INTERNAL USE BY THE ROUTINE. C IND VARIABLE THAT REPORTS THE STATUS OF THE RESULTS. C IND = 0 IF IMPROVEMENT OF X IS SUCCESSFUL WITH A C GAIN IN ACCURACY OF AT LEAST 50 PER CENT EACH C ITERATION. OTHERWISE IND = 1. C C ---------------------------------------------------------------------- COMPLEX A(KA,N), Q(KQ,N), B(N), X(N), R(N) INTEGER IPVT(N) DOUBLE PRECISION RA, IA, RX, IX, RSUM, ISUM C C ********** EPS IS A MACHINE DEPENDENT PARAMETER. ASSIGN EPS C THE VALUE U WHERE U IS THE SMALLEST FLOATING POINT C NUMBER SUCH THAT 1.0 + U .GT. 1.0. C EPS = SPMPAR(1) C IND = 0 XNRM = 0.0 DO 10 I = 1,N 10 XNRM = XNRM + (REAL(X(I))**2 + AIMAG(X(I))**2) IF (XNRM .EQ. 0.0) RETURN EPS2 = EPS*EPS RATIO = 1.0 C C COMPUTE THE RESIDUAL VECTOR C 20 DO 22 I = 1,N RSUM = DBLE(REAL(B(I))) ISUM = DBLE(AIMAG(B(I))) DO 21 J = 1,N RA = DBLE(REAL(A(I,J))) IA = DBLE(AIMAG(A(I,J))) RX = DBLE(REAL(X(J))) IX = DBLE(AIMAG(X(J))) RSUM = RSUM - RA*RX + IA*IX 21 ISUM = ISUM - RA*IX - IA*RX 22 R(I) = CMPLX(SNGL(RSUM),SNGL(ISUM)) C C FIND THE CORRECTION VECTOR C CALL CGESL(Q, KQ, N, IPVT, R, 0) RNRM = 0.0 DO 30 I = 1,N 30 RNRM = RNRM + (REAL(R(I))**2 + AIMAG(R(I))**2) IF (RNRM .LE. EPS2*XNRM) RETURN C C FORM A NEW APPROXIMATE SOLUTION C DO 40 I = 1,N 40 X(I) = X(I) + R(I) XNRM = 0.0 DO 41 I = 1,N 41 XNRM = XNRM + (REAL(X(I))**2 + AIMAG(X(I))**2) C IF (XNRM .EQ. 0.0) RETURN RAT = RATIO RATIO = RNRM/XNRM IF (RATIO .LE. 0.25*RAT) GO TO 20 C IF (RATIO .GT. AMIN1(RAT,4.0*EPS2)) IND = 1 RETURN END SUBROUTINE CGECO(A,LDA,N,IPVT,RCOND,Z) INTEGER LDA,N,IPVT(*) COMPLEX A(LDA,*),Z(*) REAL RCOND C C CGECO FACTORS A COMPLEX MATRIX BY GAUSSIAN ELIMINATION C AND ESTIMATES THE CONDITION OF THE MATRIX. C C IF RCOND IS NOT NEEDED, CGEFA IS SLIGHTLY FASTER. C TO SOLVE A*X = B , FOLLOW CGECO BY CGESL. C TO COMPUTE INVERSE(A)*C , FOLLOW CGECO BY CGESL. C TO COMPUTE DETERMINANT(A) , FOLLOW CGECO BY CGEDI. C TO COMPUTE INVERSE(A) , FOLLOW CGECO BY CGEDI. C C ON ENTRY C C A COMPLEX(LDA, N) C THE MATRIX TO BE FACTORED. C C LDA INTEGER C THE LEADING DIMENSION OF THE ARRAY A . C C N INTEGER C THE ORDER OF THE MATRIX A . C C ON RETURN C C A AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS C WHICH WERE USED TO OBTAIN IT. C THE FACTORIZATION CAN BE WRITTEN A = L*U WHERE C L IS A PRODUCT OF PERMUTATION AND UNIT LOWER C TRIANGULAR MATRICES AND U IS UPPER TRIANGULAR. C C IPVT INTEGER(N) C AN INTEGER VECTOR OF PIVOT INDICES. C C RCOND REAL C AN ESTIMATE OF THE RECIPROCAL CONDITION OF A . C FOR THE SYSTEM A*X = B , RELATIVE PERTURBATIONS C IN A AND B OF SIZE EPSILON MAY CAUSE C RELATIVE PERTURBATIONS IN X OF SIZE EPSILON/RCOND . C IF RCOND IS SO SMALL THAT THE LOGICAL EXPRESSION C 1.0 + RCOND .EQ. 1.0 C IS TRUE, THEN A MAY BE SINGULAR TO WORKING C PRECISION. IN PARTICULAR, RCOND IS ZERO IF C EXACT SINGULARITY IS DETECTED OR THE ESTIMATE C UNDERFLOWS. C C Z COMPLEX(N) C A WORK VECTOR WHOSE CONTENTS ARE USUALLY UNIMPORTANT. C IF A IS CLOSE TO A SINGULAR MATRIX, THEN Z IS C AN APPROXIMATE NULL VECTOR IN THE SENSE THAT C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . C C LINPACK. THIS VERSION DATED 08/14/78 . C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. C C SUBROUTINES AND FUNCTIONS C C LINPACK CGEFA C BLAS CAXPY,CDOTC,CSSCAL,SCASUM C FORTRAN ABS,AIMAG,AMAX1,CMPLX,CONJG,REAL C C INTERNAL VARIABLES C COMPLEX CDOTC,EK,T,WK,WKM REAL ANORM,S,SCASUM,SM,YNORM INTEGER INFO,J,K,KB,KP1,L C COMPLEX ZDUM,ZDUM1,ZDUM2,CSIGN1 REAL CABS1 CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) CSIGN1(ZDUM1,ZDUM2) = CABS1(ZDUM1)*(ZDUM2/CABS1(ZDUM2)) C C COMPUTE 1-NORM OF A C ANORM = 0.0E0 DO 10 J = 1, N ANORM = AMAX1(ANORM,SCASUM(N,A(1,J),1)) 10 CONTINUE C C FACTOR C CALL CGEFA(A,LDA,N,IPVT,INFO) C C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND CTRANS(A)*Y = E . C CTRANS(A) IS THE CONJUGATE TRANSPOSE OF A . C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL C GROWTH IN THE ELEMENTS OF W WHERE CTRANS(U)*W = E . C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. C C SOLVE CTRANS(U)*W = E C EK = (1.0E0,0.0E0) DO 20 J = 1, N Z(J) = (0.0E0,0.0E0) 20 CONTINUE DO 100 K = 1, N IF (CABS1(Z(K)) .NE. 0.0E0) EK = CSIGN1(EK,-Z(K)) IF (CABS1(EK-Z(K)) .LE. CABS1(A(K,K))) GO TO 30 S = CABS1(A(K,K))/CABS1(EK-Z(K)) CALL CSSCAL(N,S,Z,1) EK = CMPLX(S,0.0E0)*EK 30 CONTINUE WK = EK - Z(K) WKM = -EK - Z(K) S = CABS1(WK) SM = CABS1(WKM) IF (CABS1(A(K,K)) .EQ. 0.0E0) GO TO 40 WK = WK/CONJG(A(K,K)) WKM = WKM/CONJG(A(K,K)) GO TO 50 40 CONTINUE WK = (1.0E0,0.0E0) WKM = (1.0E0,0.0E0) 50 CONTINUE KP1 = K + 1 IF (KP1 .GT. N) GO TO 90 DO 60 J = KP1, N SM = SM + CABS1(Z(J)+WKM*CONJG(A(K,J))) Z(J) = Z(J) + WK*CONJG(A(K,J)) S = S + CABS1(Z(J)) 60 CONTINUE IF (S .GE. SM) GO TO 80 T = WKM - WK WK = WKM DO 70 J = KP1, N Z(J) = Z(J) + T*CONJG(A(K,J)) 70 CONTINUE 80 CONTINUE 90 CONTINUE Z(K) = WK 100 CONTINUE S = 1.0E0/SCASUM(N,Z,1) CALL CSSCAL(N,S,Z,1) C C SOLVE CTRANS(L)*Y = W C DO 120 KB = 1, N K = N + 1 - KB IF (K .LT. N) Z(K) = Z(K) + CDOTC(N-K,A(K+1,K),1,Z(K+1),1) IF (CABS1(Z(K)) .LE. 1.0E0) GO TO 110 S = 1.0E0/CABS1(Z(K)) CALL CSSCAL(N,S,Z,1) 110 CONTINUE L = IPVT(K) T = Z(L) Z(L) = Z(K) Z(K) = T 120 CONTINUE S = 1.0E0/SCASUM(N,Z,1) CALL CSSCAL(N,S,Z,1) C YNORM = 1.0E0 C C SOLVE L*V = Y C DO 140 K = 1, N L = IPVT(K) T = Z(L) Z(L) = Z(K) Z(K) = T IF (K .LT. N) CALL CAXPY(N-K,T,A(K+1,K),1,Z(K+1),1) IF (CABS1(Z(K)) .LE. 1.0E0) GO TO 130 S = 1.0E0/CABS1(Z(K)) CALL CSSCAL(N,S,Z,1) YNORM = S*YNORM 130 CONTINUE 140 CONTINUE S = 1.0E0/SCASUM(N,Z,1) CALL CSSCAL(N,S,Z,1) YNORM = S*YNORM C C SOLVE U*Z = V C DO 160 KB = 1, N K = N + 1 - KB IF (CABS1(Z(K)) .LE. CABS1(A(K,K))) GO TO 150 S = CABS1(A(K,K))/CABS1(Z(K)) CALL CSSCAL(N,S,Z,1) YNORM = S*YNORM 150 CONTINUE IF (CABS1(A(K,K)) .NE. 0.0E0) Z(K) = Z(K)/A(K,K) IF (CABS1(A(K,K)) .EQ. 0.0E0) Z(K) = (1.0E0,0.0E0) T = -Z(K) CALL CAXPY(K-1,T,A(1,K),1,Z(1),1) 160 CONTINUE C MAKE ZNORM = 1.0 S = 1.0E0/SCASUM(N,Z,1) CALL CSSCAL(N,S,Z,1) YNORM = S*YNORM C IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0 RETURN END SUBROUTINE CGEFA(A,LDA,N,IPVT,INFO) INTEGER LDA,N,IPVT(*),INFO COMPLEX A(LDA,*) C C CGEFA FACTORS A COMPLEX MATRIX BY GAUSSIAN ELIMINATION. C C CGEFA IS USUALLY CALLED BY CGECO, BUT IT CAN BE CALLED C DIRECTLY WITH A SAVING IN TIME IF RCOND IS NOT NEEDED. C (TIME FOR CGECO) = (1 + 9/N)*(TIME FOR CGEFA) . C C ON ENTRY C C A COMPLEX(LDA, N) C THE MATRIX TO BE FACTORED. C C LDA INTEGER C THE LEADING DIMENSION OF THE ARRAY A . C C N INTEGER C THE ORDER OF THE MATRIX A . C C ON RETURN C C A AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS C WHICH WERE USED TO OBTAIN IT. C THE FACTORIZATION CAN BE WRITTEN A = L*U WHERE C L IS A PRODUCT OF PERMUTATION AND UNIT LOWER C TRIANGULAR MATRICES AND U IS UPPER TRIANGULAR. C C IPVT INTEGER(N) C AN INTEGER VECTOR OF PIVOT INDICES. C C INFO INTEGER C = 0 NORMAL VALUE. C = K IF U(K,K) .EQ. 0.0 . THIS IS NOT AN ERROR C CONDITION FOR THIS SUBROUTINE, BUT IT DOES C INDICATE THAT CGESL OR CGEDI WILL DIVIDE BY ZERO C IF CALLED. USE RCOND IN CGECO FOR A RELIABLE C INDICATION OF SINGULARITY. C C LINPACK. THIS VERSION DATED 08/14/78 . C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. C C SUBROUTINES AND FUNCTIONS C C BLAS CAXPY,CSCAL,ICAMAX C FORTRAN ABS,AIMAG,REAL C C INTERNAL VARIABLES C COMPLEX T INTEGER ICAMAX,J,K,KP1,L,NM1 C COMPLEX ZDUM REAL CABS1 CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) C C GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING C INFO = 0 NM1 = N - 1 IF (NM1 .LT. 1) GO TO 70 DO 60 K = 1, NM1 KP1 = K + 1 C C FIND L = PIVOT INDEX C L = ICAMAX(N-K+1,A(K,K),1) + K - 1 IPVT(K) = L C C ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED C IF (CABS1(A(L,K)) .EQ. 0.0E0) GO TO 40 C C INTERCHANGE IF NECESSARY C IF (L .EQ. K) GO TO 10 T = A(L,K) A(L,K) = A(K,K) A(K,K) = T 10 CONTINUE C C COMPUTE MULTIPLIERS C T = -(1.0E0,0.0E0)/A(K,K) CALL CSCAL(N-K,T,A(K+1,K),1) C C ROW ELIMINATION WITH COLUMN INDEXING C DO 30 J = KP1, N T = A(L,J) IF (L .EQ. K) GO TO 20 A(L,J) = A(K,J) A(K,J) = T 20 CONTINUE CALL CAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1) 30 CONTINUE GO TO 50 40 CONTINUE INFO = K 50 CONTINUE 60 CONTINUE 70 CONTINUE IPVT(N) = N IF (CABS1(A(N,N)) .EQ. 0.0E0) INFO = N RETURN END SUBROUTINE CGESL(A,LDA,N,IPVT,B,JOB) INTEGER LDA,N,IPVT(*),JOB COMPLEX A(LDA,*),B(*) C C CGESL SOLVES THE COMPLEX SYSTEM C A * X = B OR CTRANS(A) * X = B C USING THE FACTORS COMPUTED BY CGECO OR CGEFA. C C ON ENTRY C C A COMPLEX(LDA, N) C THE OUTPUT FROM CGECO OR CGEFA. C C LDA INTEGER C THE LEADING DIMENSION OF THE ARRAY A . C C N INTEGER C THE ORDER OF THE MATRIX A . C C IPVT INTEGER(N) C THE PIVOT VECTOR FROM CGECO OR CGEFA. C C B COMPLEX(N) C THE RIGHT HAND SIDE VECTOR. C C JOB INTEGER C = 0 TO SOLVE A*X = B , C = NONZERO TO SOLVE CTRANS(A)*X = B WHERE C CTRANS(A) IS THE CONJUGATE TRANSPOSE. C C ON RETURN C C B THE SOLUTION VECTOR X . C C ERROR CONDITION C C A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A C ZERO ON THE DIAGONAL. TECHNICALLY THIS INDICATES SINGULARITY C BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER C SETTING OF LDA . IT WILL NOT OCCUR IF THE SUBROUTINES ARE C CALLED CORRECTLY AND IF CGECO HAS SET RCOND .GT. 0.0 C OR CGEFA HAS SET INFO .EQ. 0 . C C TO COMPUTE INVERSE(A) * C WHERE C IS A MATRIX C WITH P COLUMNS C CALL CGECO(A,LDA,N,IPVT,RCOND,Z) C IF (RCOND IS TOO SMALL) GO TO ... C DO 10 J = 1, P C CALL CGESL(A,LDA,N,IPVT,C(1,J),0) C 10 CONTINUE C C LINPACK. THIS VERSION DATED 08/14/78 . C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. C C SUBROUTINES AND FUNCTIONS C C BLAS CAXPY,CDOTC C FORTRAN CONJG C C INTERNAL VARIABLES C COMPLEX CDOTC,T INTEGER K,KB,L,NM1 C NM1 = N - 1 IF (JOB .NE. 0) GO TO 50 C C JOB = 0 , SOLVE A * X = B C FIRST SOLVE L*Y = B C IF (NM1 .LT. 1) GO TO 30 DO 20 K = 1, NM1 L = IPVT(K) T = B(L) IF (L .EQ. K) GO TO 10 B(L) = B(K) B(K) = T 10 CONTINUE CALL CAXPY(N-K,T,A(K+1,K),1,B(K+1),1) 20 CONTINUE 30 CONTINUE C C NOW SOLVE U*X = Y C DO 40 KB = 1, N K = N + 1 - KB B(K) = B(K)/A(K,K) T = -B(K) CALL CAXPY(K-1,T,A(1,K),1,B(1),1) 40 CONTINUE GO TO 100 50 CONTINUE C C JOB = NONZERO, SOLVE CTRANS(A) * X = B C FIRST SOLVE CTRANS(U)*Y = B C DO 60 K = 1, N T = CDOTC(K-1,A(1,K),1,B(1),1) B(K) = (B(K) - T)/CONJG(A(K,K)) 60 CONTINUE C C NOW SOLVE CTRANS(L)*X = Y C IF (NM1 .LT. 1) GO TO 90 DO 80 KB = 1, NM1 K = N - KB B(K) = B(K) + CDOTC(N-K,A(K+1,K),1,B(K+1),1) L = IPVT(K) IF (L .EQ. K) GO TO 70 T = B(L) B(L) = B(K) B(K) = T 70 CONTINUE 80 CONTINUE 90 CONTINUE 100 CONTINUE RETURN END SUBROUTINE CGEDI(A,LDA,N,IPVT,DET,WORK,JOB) INTEGER LDA,N,IPVT(*),JOB COMPLEX A(LDA,*),DET(2),WORK(*) C C CGEDI COMPUTES THE DETERMINANT AND INVERSE OF A MATRIX C USING THE FACTORS COMPUTED BY CGECO OR CGEFA. C C ON ENTRY C C A COMPLEX(LDA, N) C THE OUTPUT FROM CGECO OR CGEFA. C C LDA INTEGER C THE LEADING DIMENSION OF THE ARRAY A . C C N INTEGER C THE ORDER OF THE MATRIX A . C C IPVT INTEGER(N) C THE PIVOT VECTOR FROM CGECO OR CGEFA. C C WORK COMPLEX(N) C WORK VECTOR. CONTENTS DESTROYED. C C JOB INTEGER C = 11 BOTH DETERMINANT AND INVERSE. C = 01 INVERSE ONLY. C = 10 DETERMINANT ONLY. C C ON RETURN C C A INVERSE OF ORIGINAL MATRIX IF REQUESTED. C OTHERWISE UNCHANGED. C C DET COMPLEX(2) C DETERMINANT OF ORIGINAL MATRIX IF REQUESTED. C OTHERWISE NOT REFERENCED. C DETERMINANT = DET(1) * 10.0**DET(2) C WITH 1.0 .LE. CABS1(DET(1)) .LT. 10.0 C OR DET(1) .EQ. 0.0 . C C ERROR CONDITION C C A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS C A ZERO ON THE DIAGONAL AND THE INVERSE IS REQUESTED. C IT WILL NOT OCCUR IF THE SUBROUTINES ARE CALLED CORRECTLY C AND IF CGECO HAS SET RCOND .GT. 0.0 OR CGEFA HAS SET C INFO .EQ. 0 . C C LINPACK. THIS VERSION DATED 08/14/78 . C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. C C SUBROUTINES AND FUNCTIONS C C BLAS CAXPY,CSCAL,CSWAP C FORTRAN ABS,AIMAG,CMPLX,MOD,REAL C C INTERNAL VARIABLES C COMPLEX T REAL TEN INTEGER I,J,K,KB,KP1,L,NM1 C COMPLEX ZDUM REAL CABS1 CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) C C COMPUTE DETERMINANT C IF (JOB/10 .EQ. 0) GO TO 70 DET(1) = (1.0E0,0.0E0) DET(2) = (0.0E0,0.0E0) TEN = 10.0E0 DO 50 I = 1, N IF (IPVT(I) .NE. I) DET(1) = -DET(1) DET(1) = A(I,I)*DET(1) C ...EXIT IF (CABS1(DET(1)) .EQ. 0.0E0) GO TO 60 10 IF (CABS1(DET(1)) .GE. 1.0E0) GO TO 20 DET(1) = CMPLX(TEN,0.0E0)*DET(1) DET(2) = DET(2) - (1.0E0,0.0E0) GO TO 10 20 CONTINUE 30 IF (CABS1(DET(1)) .LT. TEN) GO TO 40 DET(1) = DET(1)/CMPLX(TEN,0.0E0) DET(2) = DET(2) + (1.0E0,0.0E0) GO TO 30 40 CONTINUE 50 CONTINUE 60 CONTINUE 70 CONTINUE C C COMPUTE INVERSE(U) C IF (MOD(JOB,10) .EQ. 0) GO TO 150 DO 100 K = 1, N A(K,K) = (1.0E0,0.0E0)/A(K,K) T = -A(K,K) CALL CSCAL(K-1,T,A(1,K),1) KP1 = K + 1 IF (N .LT. KP1) GO TO 90 DO 80 J = KP1, N T = A(K,J) A(K,J) = (0.0E0,0.0E0) CALL CAXPY(K,T,A(1,K),1,A(1,J),1) 80 CONTINUE 90 CONTINUE 100 CONTINUE C C FORM INVERSE(U)*INVERSE(L) C NM1 = N - 1 IF (NM1 .LT. 1) GO TO 140 DO 130 KB = 1, NM1 K = N - KB KP1 = K + 1 DO 110 I = KP1, N WORK(I) = A(I,K) A(I,K) = (0.0E0,0.0E0) 110 CONTINUE DO 120 J = KP1, N T = WORK(J) CALL CAXPY(N,T,A(1,J),1,A(1,K),1) 120 CONTINUE L = IPVT(K) IF (L .NE. K) CALL CSWAP(N,A(1,K),1,A(1,L),1) 130 CONTINUE 140 CONTINUE 150 CONTINUE RETURN END SUBROUTINE DCMSLV (MO,N,M,AR,AI,KA,BR,BI,KB,IERR,IPVT,WK) C----------------------------------------------------------------------- C PARTIAL PIVOT GAUSS PROCEDURE FOR INVERTING DOUBLE PRECISION C COMPLEX MATRICES AND SOLVING DOUBLE PRECISION COMPLEX EQUATIONS C----------------------------------------------------------------------- DOUBLE PRECISION AR(KA,N), AI(KA,N), BR(*), BI(*), WK(*) INTEGER IPVT(N) C IF (N .LT. 1 .OR. KA .LT. N) GO TO 30 IF (M .LE. 0) GO TO 10 IF (KB .LT. N) GO TO 30 C C MATRIX FACTORIZATION C 10 CALL DCFACT (AR, AI, KA, N, IPVT, IERR) IF (IERR .NE. 0) RETURN C C SOLUTION OF THE EQUATION AX = B C IF (M .LE. 0) GO TO 20 CALL DCSOL (N, M, AR, AI, KA, BR, BI, KB, IPVT) C C CALCULATION OF THE INVERSE OF A C 20 IF (MO .EQ. 0) CALL DCMINV (AR, AI, KA, N, IPVT, WK) RETURN C C ERROR RETURN C 30 IERR = -1 RETURN END SUBROUTINE DCFACT (AR, AI, KA, N, IPVT, IERR) C----------------------------------------------------------------------- C DECOMPOSES A COMPLEX MATRIX BY PARTIAL PIVOT GAUSS ELIMINATION C----------------------------------------------------------------------- C C INPUT ... C C AR AND AI ARE THE REAL AND IMAGINARY PARTS OF THE MATRIX A C TO BE DECOMPOSED. C C KA = DECLARED ROW DIMENSION OF THE ARRAYS AR AND AI C C N = ORDER OF THE MATRIX A C C OUTPUT ... C C AR AND AI CONTAIN AN UPPER TRIANGULAR MATRIX U AND THE C MULTIPLIERS NEEDED TO CONSTRUCT L SO THAT A = L*U . C C IPVT = THE PIVOT VECTOR. C IPVT(I) = THE INDEX OF THE K-TH PIVOT ROW (I .LT. N) C IPVT(N) = (-1)**(NUMBER OF INTERCHANGES) C C IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS. C IERR HAS ONE OF THE FOLLOWING VALUES ... C IERR = 0 THE DECOMPOSITION OF A WAS OBTAINED. C IERR = K THE K-TH PIVOT ELEMENT IS 0. C C IF IERR = 0 THEN THE DETERMINANT OF A HAS THE VALUE ... C DET(A) = IPVT(N) * A(1,1) * A(2,2) * ... * A(N,N) C----------------------------------------------------------------------- DOUBLE PRECISION AR(KA,N), AI(KA,N) INTEGER IPVT(N) DOUBLE PRECISION P, PR, PI, T, TR, TI C IERR = 0 IPVT(N) = 1 IF (N .EQ. 1) GO TO 50 NM1 = N - 1 C DO 40 K = 1,NM1 KP1 = K + 1 C C SEARCH FOR THE K-TH PIVOT ELEMENT C P = DABS(AR(K,K)) + DABS(AI(K,K)) L = K DO 10 I = KP1,N T = DABS(AR(I,K)) + DABS(AI(I,K)) IF (P .GE. T) GO TO 10 P = T L = I 10 CONTINUE IF (P .EQ. 0.D0) GO TO 100 C PR = AR(L,K) PI = AI(L,K) IPVT(K) = L IF (L .EQ. K) GO TO 20 IPVT(N) = -IPVT(N) AR(L,K) = AR(K,K) AR(K,K) = PR AI(L,K) = AI(K,K) AI(K,K) = PI C C COMPUTE THE MULTIPLIERS C 20 CALL CDIVID(1.D0, 0.D0, PR, PI, PR, PI) DO 21 I = KP1,N TR = AR(I,K) TI = AI(I,K) AR(I,K) = TR*PR - TI*PI AI(I,K) = TR*PI + TI*PR 21 CONTINUE C C INTERCHANGE AND ELIMINATE BY COLUMNS C DO 31 J = KP1,N TR = AR(L,J) AR(L,J) = AR(K,J) AR(K,J) = TR TI = AI(L,J) AI(L,J) = AI(K,J) AI(K,J) = TI IF (DABS(TR) + DABS(TI) .EQ. 0.D0) GO TO 31 DO 30 I = KP1,N AR(I,J) = AR(I,J) - AR(I,K)*TR + AI(I,K)*TI AI(I,J) = AI(I,J) - AR(I,K)*TI - AI(I,K)*TR 30 CONTINUE 31 CONTINUE 40 CONTINUE C C CHECK THE N-TH PIVOT ELEMENT C 50 IF (DABS(AR(N,N)) + DABS(AI(N,N)) .EQ. 0.D0) IERR = N RETURN C C K-TH PIVOT ELEMENT IS 0 C 100 IERR = K RETURN END SUBROUTINE DCSOL (N, M, AR, AI, KA, BR, BI, KB, IPVT) C----------------------------------------------------------------------- C SOLUTION OF THE SYSTEM OF M EQUATIONS A*X = B USING THE C DECOMPOSITION OBTAINED BY DCFACT. THIS ROUTINE CANNOT BE C USED WHEN DCFACT TERMINATES WITH NONZERO IERR. C----------------------------------------------------------------------- C C INPUT ... C C AR AND AI CONTAIN THE LU DECOMPOSITION OF THE MATRIX C OBTAINED BY DCFACT. C C KA = DECLARED ROW DIMENSION OF THE ARRAYS AR AND AI C C N = ORDER OF THE MATRIX C C BR AND BI ARE THE REAL AND IMAGINARY PARTS OF THE C RIGHT HAND SIDE MATRIX. C C KB = DECLARED ROW DIMENSION OF THE ARRAYS BR AND BI C C M = NUMBER OF COLUMNS OF B C C IPVT = PIVOT VECTOR OBTAINED FROM DCFACT C C OUTPUT ... C C BR AND BI CONTAIN THE REAL AND IMAGINARY PARTS OF THE C SOLUTION X. C C----------------------------------------------------------------------- DOUBLE PRECISION AR(KA,N), AI(KA,N), BR(KB,M), BI(KB,M) INTEGER IPVT(N) DOUBLE PRECISION PR, PI, TR, TI C C FORWARD ELIMINATION C IF (N .EQ. 1) GO TO 50 NM1 = N - 1 DO 20 K = 1, NM1 KP1 = K + 1 L = IPVT(K) DO 11 J = 1,M TR = BR(L,J) BR(L,J) = BR(K,J) BR(K,J) = TR TI = BI(L,J) BI(L,J) = BI(K,J) BI(K,J) = TI IF (DABS(TR) + DABS(TI) .EQ. 0.D0) GO TO 11 DO 10 I = KP1, N BR(I,J) = BR(I,J) - AR(I,K)*TR + AI(I,K)*TI BI(I,J) = BI(I,J) - AR(I,K)*TI - AI(I,K)*TR 10 CONTINUE 11 CONTINUE 20 CONTINUE C C BACKWARD ELIMINATION C FOR THE LAST N - 1 VARIABLES C DO 40 L = 1,NM1 KM1 = N - L K = KM1 + 1 CALL CDIVID (1.D0, 0.D0, AR(K,K), AI(K,K), PR, PI) DO 31 J = 1,M TR = BR(K,J) TI = BI(K,J) BR(K,J) = TR*PR - TI*PI BI(K,J) = TR*PI + TI*PR TR = BR(K,J) TI = BI(K,J) DO 30 I = 1, KM1 BR(I,J) = BR(I,J) - AR(I,K)*TR + AI(I,K)*TI BI(I,J) = BI(I,J) - AR(I,K)*TI - AI(I,K)*TR 30 CONTINUE 31 CONTINUE 40 CONTINUE C 50 CALL CDIVID (1.D0, 0.D0, AR(1,1), AI(1,1), PR, PI) DO 60 J = 1,M TR = BR(1,J) TI = BI(1,J) BR(1,J) = TR*PR - TI*PI BI(1,J) = TR*PI + TI*PR 60 CONTINUE RETURN END SUBROUTINE DCMINV (AR, AI, KA, N, IPVT, TEMP) C----------------------------------------------------------------------- C COMPUTATION OF THE INVERSE OF A MATRIX A USING THE LU C DECOMPOSITION OBTAINED BY DCFACT. THIS ROUTINE CANNOT C BE USED WHEN DCFACT TERMINATES WITH NONZERO IERR. C----------------------------------------------------------------------- C C INPUT ... C C AR AND AI CONTAIN THE LU DECOMPOSITION OF THE MATRIX C OBTAINED BY DCFACT. C C KA = DECLARED ROW DIMENSION OF THE ARRAYS AR AND AI C C N = ORDER OF THE MATRIX C C IPVT = PIVOT VECTOR OBTAINED FROM DCFACT C C TEMP = TEMPORARY STORAGE AREA FOR THE SUBROUTINE C C OUTPUT ... C C AR AND AI CONTAIN THE INVERSE OF THE MATRIX. C C----------------------------------------------------------------------- DOUBLE PRECISION AR(KA,N), AI(KA,N), TEMP(2,N) INTEGER IPVT(N) DOUBLE PRECISION SR, SI, TR, TI C CALL CDIVID (1.D0, 0.D0, AR(N,N), AI(N,N), AR(N,N), AI(N,N)) IF (N .EQ. 1) RETURN NP1 = N + 1 NM1 = N - 1 C C REPLACE U WITH THE INVERSE OF U C DO 20 NMI = 1,NM1 I = N - NMI IP1 = I + 1 CALL CDIVID (1.D0, 0.D0, AR(I,I), AI(I,I), TR, TI) DO 11 JB = 1,NMI J = NP1 - JB SR = 0.D0 SI = 0.D0 DO 10 L = IP1,J SR = SR + AR(I,L)*AR(L,J) - AI(I,L)*AI(L,J) SI = SI + AR(I,L)*AI(L,J) + AI(I,L)*AR(L,J) 10 CONTINUE AR(I,J) = -SR*TR + SI*TI AI(I,J) = -SR*TI - SI*TR 11 CONTINUE AR(I,I) = TR AI(I,I) = TI 20 CONTINUE C C COMPUTE INVERSE(U)*INVERSE(L) C DO 60 NMK = 1,NM1 K = N - NMK KP1 = K + 1 DO 30 I = KP1,N TEMP(1,I) = AR(I,K) TEMP(2,I) = AI(I,K) AR(I,K) = 0.D0 AI(I,K) = 0.D0 30 CONTINUE C DO 41 J = KP1,N TR = TEMP(1,J) TI = TEMP(2,J) DO 40 I = 1,N AR(I,K) = AR(I,K) - AR(I,J)*TR + AI(I,J)*TI AI(I,K) = AI(I,K) - AR(I,J)*TI - AI(I,J)*TR 40 CONTINUE 41 CONTINUE C L = IPVT(K) IF (K .EQ. L) GO TO 60 DO 50 I = 1,N TR = AR(I,K) AR(I,K) = AR(I,L) AR(I,L) = TR TI = AI(I,K) AI(I,K) = AI(I,L) 50 AI(I,L) = TI 60 CONTINUE RETURN END SUBROUTINE SSVDC(X,LDX,N,P,S,E,U,LDU,V,LDV,WORK,JOB,INFO) INTEGER LDX,N,P,LDU,LDV,JOB,INFO REAL X(LDX,*),S(*),E(*),U(LDU,*),V(LDV,*),WORK(*) C C C SSVDC IS A SUBROUTINE TO REDUCE A REAL NXP MATRIX X BY C ORTHOGONAL TRANSFORMATIONS U AND V TO DIAGONAL FORM. THE C DIAGONAL ELEMENTS S(I) ARE THE SINGULAR VALUES OF X. THE C COLUMNS OF U ARE THE CORRESPONDING LEFT SINGULAR VECTORS, C AND THE COLUMNS OF V THE RIGHT SINGULAR VECTORS. C C ON ENTRY C C X REAL(LDX,P), WHERE LDX.GE.N. C X CONTAINS THE MATRIX WHOSE SINGULAR VALUE C DECOMPOSITION IS TO BE COMPUTED. X IS C DESTROYED BY SSVDC. C C LDX INTEGER. C LDX IS THE LEADING DIMENSION OF THE ARRAY X. C C N INTEGER. C N IS THE NUMBER OF ROWS OF THE MATRIX X. C C P INTEGER. C P IS THE NUMBER OF COLUMNS OF THE MATRIX X. C C LDU INTEGER. C LDU IS THE LEADING DIMENSION OF THE ARRAY U. C (SEE BELOW). C C LDV INTEGER. C LDV IS THE LEADING DIMENSION OF THE ARRAY V. C (SEE BELOW). C C WORK REAL(N). C WORK IS A SCRATCH ARRAY. C C JOB INTEGER. C JOB CONTROLS THE COMPUTATION OF THE SINGULAR C VECTORS. IT HAS THE DECIMAL EXPANSION AB C WITH THE FOLLOWING MEANING C C A.EQ.0 DO NOT COMPUTE THE LEFT SINGULAR C VECTORS. C A.EQ.1 RETURN THE N LEFT SINGULAR VECTORS C IN U. C A.GE.2 RETURN THE FIRST MIN(N,P) SINGULAR C VECTORS IN U. C B.EQ.0 DO NOT COMPUTE THE RIGHT SINGULAR C VECTORS. C B.EQ.1 RETURN THE RIGHT SINGULAR VECTORS C IN V. C C ON RETURN C C S REAL(MM), WHERE MM=MIN(N+1,P). C THE FIRST MIN(N,P) ENTRIES OF S CONTAIN THE C SINGULAR VALUES OF X ARRANGED IN DESCENDING C ORDER OF MAGNITUDE. C C E REAL(P). C E ORDINARILY CONTAINS ZEROS. HOWEVER SEE THE C DISCUSSION OF INFO FOR EXCEPTIONS. C C U REAL(LDU,K), WHERE LDU.GE.N. IF JOBA.EQ.1 THEN C K.EQ.N, IF JOBA.GE.2 THEN C K.EQ.MIN(N,P). C U CONTAINS THE MATRIX OF LEFT SINGULAR VECTORS. C U IS NOT REFERENCED IF JOBA.EQ.0. IF N.LE.P C OR IF JOBA.EQ.2, THEN U MAY BE IDENTIFIED WITH X C IN THE SUBROUTINE CALL. C C V REAL(LDV,P), WHERE LDV.GE.P. C V CONTAINS THE MATRIX OF RIGHT SINGULAR VECTORS. C V IS NOT REFERENCED IF JOB.EQ.0. IF P.LE.N, C THEN V MAY BE IDENTIFIED WITH X IN THE C SUBROUTINE CALL. C C INFO INTEGER. C THE SINGULAR VALUES (AND THEIR CORRESPONDING C SINGULAR VECTORS) S(INFO+1),S(INFO+2),...,S(M) C ARE CORRECT (HERE M=MIN(N,P)). THUS IF C INFO.EQ.0, ALL THE SINGULAR VALUES AND THEIR C VECTORS ARE CORRECT. IN ANY EVENT, THE MATRIX C B = TRANS(U)*X*V IS THE BIDIAGONAL MATRIX C WITH THE ELEMENTS OF S ON ITS DIAGONAL AND THE C ELEMENTS OF E ON ITS SUPER-DIAGONAL (TRANS(U) C IS THE TRANSPOSE OF U). THUS THE SINGULAR C VALUES OF X AND B ARE THE SAME. C C LINPACK. THIS VERSION DATED 03/19/79 . C G.W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB. C C ***** USES THE FOLLOWING FUNCTIONS AND SUBPROGRAMS. C C EXTERNAL SROT C BLAS SAXPY,SDOT,SSCAL,SSWAP,SNRM2,SROTG C FORTRAN ABS,AMAX1,MAX0,MIN0,MOD,SQRT C C INTERNAL VARIABLES C INTEGER I,ITER,J,JOBU,K,KASE,KK,L,LL,LLS,LM1,LP1,LS,LU,M,MAXIT, * MM,MM1,MP1,NCT,NCTP1,NCU,NRT,NRTP1 REAL SDOT,T REAL B,C,CS,EL,EMM1,F,G,SNRM2,SCALE,SHIFT,SL,SM,SN,SMM1,T1,TEST, * ZTEST LOGICAL WANTU,WANTV C C C SET THE MAXIMUM NUMBER OF ITERATIONS. C MAXIT = 30 C C DETERMINE WHAT IS TO BE COMPUTED. C WANTU = .FALSE. WANTV = .FALSE. JOBU = MOD(JOB,100)/10 NCU = N IF (JOBU .GT. 1) NCU = MIN0(N,P) IF (JOBU .NE. 0) WANTU = .TRUE. IF (MOD(JOB,10) .NE. 0) WANTV = .TRUE. C C REDUCE X TO BIDIAGONAL FORM, STORING THE DIAGONAL ELEMENTS C IN S AND THE SUPER-DIAGONAL ELEMENTS IN E. C INFO = 0 NCT = MIN0(N-1,P) NRT = MAX0(0,MIN0(P-2,N)) LU = MAX0(NCT,NRT) IF (LU .LT. 1) GO TO 170 DO 160 L = 1, LU LP1 = L + 1 IF (L .GT. NCT) GO TO 20 C C COMPUTE THE TRANSFORMATION FOR THE L-TH COLUMN AND C PLACE THE L-TH DIAGONAL IN S(L). C S(L) = SNRM2(N-L+1,X(L,L),1) IF (S(L) .EQ. 0.0E0) GO TO 10 IF (X(L,L) .NE. 0.0E0) S(L) = SIGN(S(L),X(L,L)) CALL SSCAL(N-L+1,1.0E0/S(L),X(L,L),1) X(L,L) = 1.0E0 + X(L,L) 10 CONTINUE S(L) = -S(L) 20 CONTINUE IF (P .LT. LP1) GO TO 50 DO 40 J = LP1, P IF (L .GT. NCT) GO TO 30 IF (S(L) .EQ. 0.0E0) GO TO 30 C C APPLY THE TRANSFORMATION. C T = -SDOT(N-L+1,X(L,L),1,X(L,J),1)/X(L,L) CALL SAXPY(N-L+1,T,X(L,L),1,X(L,J),1) 30 CONTINUE C C PLACE THE L-TH ROW OF X INTO E FOR THE C SUBSEQUENT CALCULATION OF THE ROW TRANSFORMATION. C E(J) = X(L,J) 40 CONTINUE 50 CONTINUE IF (.NOT.WANTU .OR. L .GT. NCT) GO TO 70 C C PLACE THE TRANSFORMATION IN U FOR SUBSEQUENT BACK C MULTIPLICATION. C DO 60 I = L, N U(I,L) = X(I,L) 60 CONTINUE 70 CONTINUE IF (L .GT. NRT) GO TO 150 C C COMPUTE THE L-TH ROW TRANSFORMATION AND PLACE THE C L-TH SUPER-DIAGONAL IN E(L). C E(L) = SNRM2(P-L,E(LP1),1) IF (E(L) .EQ. 0.0E0) GO TO 80 IF (E(LP1) .NE. 0.0E0) E(L) = SIGN(E(L),E(LP1)) CALL SSCAL(P-L,1.0E0/E(L),E(LP1),1) E(LP1) = 1.0E0 + E(LP1) 80 CONTINUE E(L) = -E(L) IF (LP1 .GT. N .OR. E(L) .EQ. 0.0E0) GO TO 120 C C APPLY THE TRANSFORMATION. C DO 90 I = LP1, N WORK(I) = 0.0E0 90 CONTINUE DO 100 J = LP1, P CALL SAXPY(N-L,E(J),X(LP1,J),1,WORK(LP1),1) 100 CONTINUE DO 110 J = LP1, P CALL SAXPY(N-L,-E(J)/E(LP1),WORK(LP1),1,X(LP1,J),1) 110 CONTINUE 120 CONTINUE IF (.NOT.WANTV) GO TO 140 C C PLACE THE TRANSFORMATION IN V FOR SUBSEQUENT C BACK MULTIPLICATION. C DO 130 I = LP1, P V(I,L) = E(I) 130 CONTINUE 140 CONTINUE 150 CONTINUE 160 CONTINUE 170 CONTINUE C C SET UP THE FINAL BIDIAGONAL MATRIX OF ORDER M. C M = MIN0(P,N+1) NCTP1 = NCT + 1 NRTP1 = NRT + 1 IF (NCT .LT. P) S(NCTP1) = X(NCTP1,NCTP1) IF (N .LT. M) S(M) = 0.0E0 IF (NRTP1 .LT. M) E(NRTP1) = X(NRTP1,M) E(M) = 0.0E0 C C IF REQUIRED, GENERATE U. C IF (.NOT.WANTU) GO TO 300 IF (NCU .LT. NCTP1) GO TO 200 DO 190 J = NCTP1, NCU DO 180 I = 1, N U(I,J) = 0.0E0 180 CONTINUE U(J,J) = 1.0E0 190 CONTINUE 200 CONTINUE IF (NCT .LT. 1) GO TO 290 DO 280 LL = 1, NCT L = NCT - LL + 1 IF (S(L) .EQ. 0.0E0) GO TO 250 LP1 = L + 1 IF (NCU .LT. LP1) GO TO 220 DO 210 J = LP1, NCU T = -SDOT(N-L+1,U(L,L),1,U(L,J),1)/U(L,L) CALL SAXPY(N-L+1,T,U(L,L),1,U(L,J),1) 210 CONTINUE 220 CONTINUE CALL SSCAL(N-L+1,-1.0E0,U(L,L),1) U(L,L) = 1.0E0 + U(L,L) LM1 = L - 1 IF (LM1 .LT. 1) GO TO 240 DO 230 I = 1, LM1 U(I,L) = 0.0E0 230 CONTINUE 240 CONTINUE GO TO 270 250 CONTINUE DO 260 I = 1, N U(I,L) = 0.0E0 260 CONTINUE U(L,L) = 1.0E0 270 CONTINUE 280 CONTINUE 290 CONTINUE 300 CONTINUE C C IF IT IS REQUIRED, GENERATE V. C IF (.NOT.WANTV) GO TO 350 DO 340 LL = 1, P L = P - LL + 1 LP1 = L + 1 IF (L .GT. NRT) GO TO 320 IF (E(L) .EQ. 0.0E0) GO TO 320 DO 310 J = LP1, P T = -SDOT(P-L,V(LP1,L),1,V(LP1,J),1)/V(LP1,L) CALL SAXPY(P-L,T,V(LP1,L),1,V(LP1,J),1) 310 CONTINUE 320 CONTINUE DO 330 I = 1, P V(I,L) = 0.0E0 330 CONTINUE V(L,L) = 1.0E0 340 CONTINUE 350 CONTINUE C C MAIN ITERATION LOOP FOR THE SINGULAR VALUES. C MM = M ITER = 0 360 CONTINUE C C QUIT IF ALL THE SINGULAR VALUES HAVE BEEN FOUND. C C ...EXIT IF (M .EQ. 0) GO TO 620 C C IF TOO MANY ITERATIONS HAVE BEEN PERFORMED, SET C FLAG AND RETURN. C IF (ITER .LT. MAXIT) GO TO 370 INFO = M C ......EXIT GO TO 620 370 CONTINUE C C THIS SECTION OF THE PROGRAM INSPECTS FOR C NEGLIGIBLE ELEMENTS IN THE S AND E ARRAYS. ON C COMPLETION THE VARIABLES KASE AND L ARE SET AS FOLLOWS. C C KASE = 1 IF S(M) AND E(L-1) ARE NEGLIGIBLE AND L.LT.M C KASE = 2 IF S(L) IS NEGLIGIBLE AND L.LT.M C KASE = 3 IF E(L-1) IS NEGLIGIBLE, L.LT.M, AND C S(L), ..., S(M) ARE NOT NEGLIGIBLE (QR STEP). C KASE = 4 IF E(M-1) IS NEGLIGIBLE (CONVERGENCE). C DO 390 LL = 1, M L = M - LL C ...EXIT IF (L .EQ. 0) GO TO 400 TEST = ABS(S(L)) + ABS(S(L+1)) ZTEST = TEST + ABS(E(L)) IF (ZTEST .NE. TEST) GO TO 380 E(L) = 0.0E0 C ......EXIT GO TO 400 380 CONTINUE 390 CONTINUE 400 CONTINUE IF (L .NE. M - 1) GO TO 410 KASE = 4 GO TO 480 410 CONTINUE LP1 = L + 1 MP1 = M + 1 DO 430 LLS = LP1, MP1 LS = M - LLS + LP1 C ...EXIT IF (LS .EQ. L) GO TO 440 TEST = 0.0E0 IF (LS .NE. M) TEST = TEST + ABS(E(LS)) IF (LS .NE. L + 1) TEST = TEST + ABS(E(LS-1)) ZTEST = TEST + ABS(S(LS)) IF (ZTEST .NE. TEST) GO TO 420 S(LS) = 0.0E0 C ......EXIT GO TO 440 420 CONTINUE 430 CONTINUE 440 CONTINUE IF (LS .NE. L) GO TO 450 KASE = 3 GO TO 470 450 CONTINUE IF (LS .NE. M) GO TO 460 KASE = 1 GO TO 470 460 CONTINUE KASE = 2 L = LS 470 CONTINUE 480 CONTINUE L = L + 1 C C PERFORM THE TASK INDICATED BY KASE. C GO TO (490,520,540,570), KASE C C DEFLATE NEGLIGIBLE S(M). C 490 CONTINUE MM1 = M - 1 F = E(M-1) E(M-1) = 0.0E0 DO 510 KK = L, MM1 K = MM1 - KK + L T1 = S(K) CALL SROTG(T1,F,CS,SN) S(K) = T1 IF (K .EQ. L) GO TO 500 F = -SN*E(K-1) E(K-1) = CS*E(K-1) 500 CONTINUE IF (WANTV) CALL SROT(P,V(1,K),1,V(1,M),1,CS,SN) 510 CONTINUE GO TO 610 C C SPLIT AT NEGLIGIBLE S(L). C 520 CONTINUE F = E(L-1) E(L-1) = 0.0E0 DO 530 K = L, M T1 = S(K) CALL SROTG(T1,F,CS,SN) S(K) = T1 F = -SN*E(K) E(K) = CS*E(K) IF (WANTU) CALL SROT(N,U(1,K),1,U(1,L-1),1,CS,SN) 530 CONTINUE GO TO 610 C C PERFORM ONE QR STEP. C 540 CONTINUE C C CALCULATE THE SHIFT. C SCALE = AMAX1(ABS(S(M)),ABS(S(M-1)),ABS(E(M-1)),ABS(S(L)), * ABS(E(L))) SM = S(M)/SCALE SMM1 = S(M-1)/SCALE EMM1 = E(M-1)/SCALE SL = S(L)/SCALE EL = E(L)/SCALE B = ((SMM1 + SM)*(SMM1 - SM) + EMM1**2)/2.0E0 C = (SM*EMM1)**2 SHIFT = 0.0E0 IF (B .EQ. 0.0E0 .AND. C .EQ. 0.0E0) GO TO 550 SHIFT = SQRT(B**2+C) IF (B .LT. 0.0E0) SHIFT = -SHIFT SHIFT = C/(B + SHIFT) 550 CONTINUE F = (SL + SM)*(SL - SM) - SHIFT G = SL*EL C C CHASE ZEROS. C MM1 = M - 1 DO 560 K = L, MM1 CALL SROTG(F,G,CS,SN) IF (K .NE. L) E(K-1) = F F = CS*S(K) + SN*E(K) E(K) = CS*E(K) - SN*S(K) G = SN*S(K+1) S(K+1) = CS*S(K+1) IF (WANTV) CALL SROT(P,V(1,K),1,V(1,K+1),1,CS,SN) CALL SROTG(F,G,CS,SN) S(K) = F F = CS*E(K) + SN*S(K+1) S(K+1) = -SN*E(K) + CS*S(K+1) G = SN*E(K+1) E(K+1) = CS*E(K+1) IF (WANTU .AND. K .LT. N) * CALL SROT(N,U(1,K),1,U(1,K+1),1,CS,SN) 560 CONTINUE E(M-1) = F ITER = ITER + 1 GO TO 610 C C CONVERGENCE. C 570 CONTINUE C C MAKE THE SINGULAR VALUE POSITIVE. C IF (S(L) .GE. 0.0E0) GO TO 580 S(L) = -S(L) IF (WANTV) CALL SSCAL(P,-1.0E0,V(1,L),1) 580 CONTINUE C C ORDER THE SINGULAR VALUE. C 590 IF (L .EQ. MM) GO TO 600 C ...EXIT IF (S(L) .GE. S(L+1)) GO TO 600 T = S(L) S(L) = S(L+1) S(L+1) = T IF (WANTV .AND. L .LT. P) * CALL SSWAP(P,V(1,L),1,V(1,L+1),1) IF (WANTU .AND. L .LT. N) * CALL SSWAP(N,U(1,L),1,U(1,L+1),1) L = L + 1 GO TO 590 600 CONTINUE ITER = 0 M = M - 1 610 CONTINUE GO TO 360 620 CONTINUE RETURN END SUBROUTINE DSVDC(X,LDX,N,P,S,E,U,LDU,V,LDV,WORK,JOB,INFO) INTEGER LDX,N,P,LDU,LDV,JOB,INFO DOUBLE PRECISION X(LDX,*),S(*),E(*),U(LDU,*),V(LDV,*),WORK(*) C C C DSVDC IS A SUBROUTINE TO REDUCE A DOUBLE PRECISION NXP MATRIX X C BY ORTHOGONAL TRANSFORMATIONS U AND V TO DIAGONAL FORM. THE C DIAGONAL ELEMENTS S(I) ARE THE SINGULAR VALUES OF X. THE C COLUMNS OF U ARE THE CORRESPONDING LEFT SINGULAR VECTORS, C AND THE COLUMNS OF V THE RIGHT SINGULAR VECTORS. C C ON ENTRY C C X DOUBLE PRECISION(LDX,P), WHERE LDX.GE.N. C X CONTAINS THE MATRIX WHOSE SINGULAR VALUE C DECOMPOSITION IS TO BE COMPUTED. X IS C DESTROYED BY DSVDC. C C LDX INTEGER. C LDX IS THE LEADING DIMENSION OF THE ARRAY X. C C N INTEGER. C N IS THE NUMBER OF ROWS OF THE MATRIX X. C C P INTEGER. C P IS THE NUMBER OF COLUMNS OF THE MATRIX X. C C LDU INTEGER. C LDU IS THE LEADING DIMENSION OF THE ARRAY U. C (SEE BELOW). C C LDV INTEGER. C LDV IS THE LEADING DIMENSION OF THE ARRAY V. C (SEE BELOW). C C WORK DOUBLE PRECISION(N). C WORK IS A SCRATCH ARRAY. C C JOB INTEGER. C JOB CONTROLS THE COMPUTATION OF THE SINGULAR C VECTORS. IT HAS THE DECIMAL EXPANSION AB C WITH THE FOLLOWING MEANING C C A.EQ.0 DO NOT COMPUTE THE LEFT SINGULAR C VECTORS. C A.EQ.1 RETURN THE N LEFT SINGULAR VECTORS C IN U. C A.GE.2 RETURN THE FIRST MIN(N,P) SINGULAR C VECTORS IN U. C B.EQ.0 DO NOT COMPUTE THE RIGHT SINGULAR C VECTORS. C B.EQ.1 RETURN THE RIGHT SINGULAR VECTORS C IN V. C C ON RETURN C C S DOUBLE PRECISION(MM), WHERE MM=MIN(N+1,P). C THE FIRST MIN(N,P) ENTRIES OF S CONTAIN THE C SINGULAR VALUES OF X ARRANGED IN DESCENDING C ORDER OF MAGNITUDE. C C E DOUBLE PRECISION(P). C E ORDINARILY CONTAINS ZEROS. HOWEVER SEE THE C DISCUSSION OF INFO FOR EXCEPTIONS. C C U DOUBLE PRECISION(LDU,K), WHERE LDU.GE.N. IF C JOBA.EQ.1 THEN K.EQ.N, IF JOBA.GE.2 C THEN K.EQ.MIN(N,P). C U CONTAINS THE MATRIX OF LEFT SINGULAR VECTORS. C U IS NOT REFERENCED IF JOBA.EQ.0. IF N.LE.P C OR IF JOBA.EQ.2, THEN U MAY BE IDENTIFIED WITH X C IN THE SUBROUTINE CALL. C C V DOUBLE PRECISION(LDV,P), WHERE LDV.GE.P. C V CONTAINS THE MATRIX OF RIGHT SINGULAR VECTORS. C V IS NOT REFERENCED IF JOB.EQ.0. IF P.LE.N, C THEN V MAY BE IDENTIFIED WITH X IN THE C SUBROUTINE CALL. C C INFO INTEGER. C THE SINGULAR VALUES (AND THEIR CORRESPONDING C SINGULAR VECTORS) S(INFO+1),S(INFO+2),...,S(M) C ARE CORRECT (HERE M=MIN(N,P)). THUS IF C INFO.EQ.0, ALL THE SINGULAR VALUES AND THEIR C VECTORS ARE CORRECT. IN ANY EVENT, THE MATRIX C B = TRANS(U)*X*V IS THE BIDIAGONAL MATRIX C WITH THE ELEMENTS OF S ON ITS DIAGONAL AND THE C ELEMENTS OF E ON ITS SUPER-DIAGONAL (TRANS(U) C IS THE TRANSPOSE OF U). THUS THE SINGULAR C VALUES OF X AND B ARE THE SAME. C C LINPACK. THIS VERSION DATED 03/19/79 . C G.W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB. C C DSVDC USES THE FOLLOWING FUNCTIONS AND SUBPROGRAMS. C C EXTERNAL DROT C BLAS DAXPY,DDOT,DSCAL,DSWAP,DNRM2,DROTG C FORTRAN DABS,DMAX1,MAX0,MIN0,MOD,DSQRT C C INTERNAL VARIABLES C INTEGER I,ITER,J,JOBU,K,KASE,KK,L,LL,LLS,LM1,LP1,LS,LU,M,MAXIT, * MM,MM1,MP1,NCT,NCTP1,NCU,NRT,NRTP1 DOUBLE PRECISION DDOT,T DOUBLE PRECISION B,C,CS,EL,EMM1,F,G,DNRM2,SCALE,SHIFT,SL,SM,SN, * SMM1,T1,TEST,ZTEST LOGICAL WANTU,WANTV C C C SET THE MAXIMUM NUMBER OF ITERATIONS. C MAXIT = 30 C C DETERMINE WHAT IS TO BE COMPUTED. C WANTU = .FALSE. WANTV = .FALSE. JOBU = MOD(JOB,100)/10 NCU = N IF (JOBU .GT. 1) NCU = MIN0(N,P) IF (JOBU .NE. 0) WANTU = .TRUE. IF (MOD(JOB,10) .NE. 0) WANTV = .TRUE. C C REDUCE X TO BIDIAGONAL FORM, STORING THE DIAGONAL ELEMENTS C IN S AND THE SUPER-DIAGONAL ELEMENTS IN E. C INFO = 0 NCT = MIN0(N-1,P) NRT = MAX0(0,MIN0(P-2,N)) LU = MAX0(NCT,NRT) IF (LU .LT. 1) GO TO 170 DO 160 L = 1, LU LP1 = L + 1 IF (L .GT. NCT) GO TO 20 C C COMPUTE THE TRANSFORMATION FOR THE L-TH COLUMN AND C PLACE THE L-TH DIAGONAL IN S(L). C S(L) = DNRM2(N-L+1,X(L,L),1) IF (S(L) .EQ. 0.0D0) GO TO 10 IF (X(L,L) .NE. 0.0D0) S(L) = DSIGN(S(L),X(L,L)) CALL DSCAL(N-L+1,1.0D0/S(L),X(L,L),1) X(L,L) = 1.0D0 + X(L,L) 10 CONTINUE S(L) = -S(L) 20 CONTINUE IF (P .LT. LP1) GO TO 50 DO 40 J = LP1, P IF (L .GT. NCT) GO TO 30 IF (S(L) .EQ. 0.0D0) GO TO 30 C C APPLY THE TRANSFORMATION. C T = -DDOT(N-L+1,X(L,L),1,X(L,J),1)/X(L,L) CALL DAXPY(N-L+1,T,X(L,L),1,X(L,J),1) 30 CONTINUE C C PLACE THE L-TH ROW OF X INTO E FOR THE C SUBSEQUENT CALCULATION OF THE ROW TRANSFORMATION. C E(J) = X(L,J) 40 CONTINUE 50 CONTINUE IF (.NOT.WANTU .OR. L .GT. NCT) GO TO 70 C C PLACE THE TRANSFORMATION IN U FOR SUBSEQUENT BACK C MULTIPLICATION. C DO 60 I = L, N U(I,L) = X(I,L) 60 CONTINUE 70 CONTINUE IF (L .GT. NRT) GO TO 150 C C COMPUTE THE L-TH ROW TRANSFORMATION AND PLACE THE C L-TH SUPER-DIAGONAL IN E(L). C E(L) = DNRM2(P-L,E(LP1),1) IF (E(L) .EQ. 0.0D0) GO TO 80 IF (E(LP1) .NE. 0.0D0) E(L) = DSIGN(E(L),E(LP1)) CALL DSCAL(P-L,1.0D0/E(L),E(LP1),1) E(LP1) = 1.0D0 + E(LP1) 80 CONTINUE E(L) = -E(L) IF (LP1 .GT. N .OR. E(L) .EQ. 0.0D0) GO TO 120 C C APPLY THE TRANSFORMATION. C DO 90 I = LP1, N WORK(I) = 0.0D0 90 CONTINUE DO 100 J = LP1, P CALL DAXPY(N-L,E(J),X(LP1,J),1,WORK(LP1),1) 100 CONTINUE DO 110 J = LP1, P CALL DAXPY(N-L,-E(J)/E(LP1),WORK(LP1),1,X(LP1,J),1) 110 CONTINUE 120 CONTINUE IF (.NOT.WANTV) GO TO 140 C C PLACE THE TRANSFORMATION IN V FOR SUBSEQUENT C BACK MULTIPLICATION. C DO 130 I = LP1, P V(I,L) = E(I) 130 CONTINUE 140 CONTINUE 150 CONTINUE 160 CONTINUE 170 CONTINUE C C SET UP THE FINAL BIDIAGONAL MATRIX OF ORDER M. C M = MIN0(P,N+1) NCTP1 = NCT + 1 NRTP1 = NRT + 1 IF (NCT .LT. P) S(NCTP1) = X(NCTP1,NCTP1) IF (N .LT. M) S(M) = 0.0D0 IF (NRTP1 .LT. M) E(NRTP1) = X(NRTP1,M) E(M) = 0.0D0 C C IF REQUIRED, GENERATE U. C IF (.NOT.WANTU) GO TO 300 IF (NCU .LT. NCTP1) GO TO 200 DO 190 J = NCTP1, NCU DO 180 I = 1, N U(I,J) = 0.0D0 180 CONTINUE U(J,J) = 1.0D0 190 CONTINUE 200 CONTINUE IF (NCT .LT. 1) GO TO 290 DO 280 LL = 1, NCT L = NCT - LL + 1 IF (S(L) .EQ. 0.0D0) GO TO 250 LP1 = L + 1 IF (NCU .LT. LP1) GO TO 220 DO 210 J = LP1, NCU T = -DDOT(N-L+1,U(L,L),1,U(L,J),1)/U(L,L) CALL DAXPY(N-L+1,T,U(L,L),1,U(L,J),1) 210 CONTINUE 220 CONTINUE CALL DSCAL(N-L+1,-1.0D0,U(L,L),1) U(L,L) = 1.0D0 + U(L,L) LM1 = L - 1 IF (LM1 .LT. 1) GO TO 240 DO 230 I = 1, LM1 U(I,L) = 0.0D0 230 CONTINUE 240 CONTINUE GO TO 270 250 CONTINUE DO 260 I = 1, N U(I,L) = 0.0D0 260 CONTINUE U(L,L) = 1.0D0 270 CONTINUE 280 CONTINUE 290 CONTINUE 300 CONTINUE C C IF IT IS REQUIRED, GENERATE V. C IF (.NOT.WANTV) GO TO 350 DO 340 LL = 1, P L = P - LL + 1 LP1 = L + 1 IF (L .GT. NRT) GO TO 320 IF (E(L) .EQ. 0.0D0) GO TO 320 DO 310 J = LP1, P T = -DDOT(P-L,V(LP1,L),1,V(LP1,J),1)/V(LP1,L) CALL DAXPY(P-L,T,V(LP1,L),1,V(LP1,J),1) 310 CONTINUE 320 CONTINUE DO 330 I = 1, P V(I,L) = 0.0D0 330 CONTINUE V(L,L) = 1.0D0 340 CONTINUE 350 CONTINUE C C MAIN ITERATION LOOP FOR THE SINGULAR VALUES. C MM = M ITER = 0 360 CONTINUE C C QUIT IF ALL THE SINGULAR VALUES HAVE BEEN FOUND. C C ...EXIT IF (M .EQ. 0) GO TO 620 C C IF TOO MANY ITERATIONS HAVE BEEN PERFORMED, SET C FLAG AND RETURN. C IF (ITER .LT. MAXIT) GO TO 370 INFO = M C ......EXIT GO TO 620 370 CONTINUE C C THIS SECTION OF THE PROGRAM INSPECTS FOR C NEGLIGIBLE ELEMENTS IN THE S AND E ARRAYS. ON C COMPLETION THE VARIABLES KASE AND L ARE SET AS FOLLOWS. C C KASE = 1 IF S(M) AND E(L-1) ARE NEGLIGIBLE AND L.LT.M C KASE = 2 IF S(L) IS NEGLIGIBLE AND L.LT.M C KASE = 3 IF E(L-1) IS NEGLIGIBLE, L.LT.M, AND C S(L), ..., S(M) ARE NOT NEGLIGIBLE (QR STEP). C KASE = 4 IF E(M-1) IS NEGLIGIBLE (CONVERGENCE). C DO 390 LL = 1, M L = M - LL C ...EXIT IF (L .EQ. 0) GO TO 400 TEST = DABS(S(L)) + DABS(S(L+1)) ZTEST = TEST + DABS(E(L)) IF (ZTEST .NE. TEST) GO TO 380 E(L) = 0.0D0 C ......EXIT GO TO 400 380 CONTINUE 390 CONTINUE 400 CONTINUE IF (L .NE. M - 1) GO TO 410 KASE = 4 GO TO 480 410 CONTINUE LP1 = L + 1 MP1 = M + 1 DO 430 LLS = LP1, MP1 LS = M - LLS + LP1 C ...EXIT IF (LS .EQ. L) GO TO 440 TEST = 0.0D0 IF (LS .NE. M) TEST = TEST + DABS(E(LS)) IF (LS .NE. L + 1) TEST = TEST + DABS(E(LS-1)) ZTEST = TEST + DABS(S(LS)) IF (ZTEST .NE. TEST) GO TO 420 S(LS) = 0.0D0 C ......EXIT GO TO 440 420 CONTINUE 430 CONTINUE 440 CONTINUE IF (LS .NE. L) GO TO 450 KASE = 3 GO TO 470 450 CONTINUE IF (LS .NE. M) GO TO 460 KASE = 1 GO TO 470 460 CONTINUE KASE = 2 L = LS 470 CONTINUE 480 CONTINUE L = L + 1 C C PERFORM THE TASK INDICATED BY KASE. C GO TO (490,520,540,570), KASE C C DEFLATE NEGLIGIBLE S(M). C 490 CONTINUE MM1 = M - 1 F = E(M-1) E(M-1) = 0.0D0 DO 510 KK = L, MM1 K = MM1 - KK + L T1 = S(K) CALL DROTG(T1,F,CS,SN) S(K) = T1 IF (K .EQ. L) GO TO 500 F = -SN*E(K-1) E(K-1) = CS*E(K-1) 500 CONTINUE IF (WANTV) CALL DROT(P,V(1,K),1,V(1,M),1,CS,SN) 510 CONTINUE GO TO 610 C C SPLIT AT NEGLIGIBLE S(L). C 520 CONTINUE F = E(L-1) E(L-1) = 0.0D0 DO 530 K = L, M T1 = S(K) CALL DROTG(T1,F,CS,SN) S(K) = T1 F = -SN*E(K) E(K) = CS*E(K) IF (WANTU) CALL DROT(N,U(1,K),1,U(1,L-1),1,CS,SN) 530 CONTINUE GO TO 610 C C PERFORM ONE QR STEP. C 540 CONTINUE C C CALCULATE THE SHIFT. C SCALE = DMAX1(DABS(S(M)),DABS(S(M-1)),DABS(E(M-1)), * DABS(S(L)),DABS(E(L))) SM = S(M)/SCALE SMM1 = S(M-1)/SCALE EMM1 = E(M-1)/SCALE SL = S(L)/SCALE EL = E(L)/SCALE B = ((SMM1 + SM)*(SMM1 - SM) + EMM1**2)/2.0D0 C = (SM*EMM1)**2 SHIFT = 0.0D0 IF (B .EQ. 0.0D0 .AND. C .EQ. 0.0D0) GO TO 550 SHIFT = DSQRT(B**2+C) IF (B .LT. 0.0D0) SHIFT = -SHIFT SHIFT = C/(B + SHIFT) 550 CONTINUE F = (SL + SM)*(SL - SM) - SHIFT G = SL*EL C C CHASE ZEROS. C MM1 = M - 1 DO 560 K = L, MM1 CALL DROTG(F,G,CS,SN) IF (K .NE. L) E(K-1) = F F = CS*S(K) + SN*E(K) E(K) = CS*E(K) - SN*S(K) G = SN*S(K+1) S(K+1) = CS*S(K+1) IF (WANTV) CALL DROT(P,V(1,K),1,V(1,K+1),1,CS,SN) CALL DROTG(F,G,CS,SN) S(K) = F F = CS*E(K) + SN*S(K+1) S(K+1) = -SN*E(K) + CS*S(K+1) G = SN*E(K+1) E(K+1) = CS*E(K+1) IF (WANTU .AND. K .LT. N) * CALL DROT(N,U(1,K),1,U(1,K+1),1,CS,SN) 560 CONTINUE E(M-1) = F ITER = ITER + 1 GO TO 610 C C CONVERGENCE. C 570 CONTINUE C C MAKE THE SINGULAR VALUE POSITIVE. C IF (S(L) .GE. 0.0D0) GO TO 580 S(L) = -S(L) IF (WANTV) CALL DSCAL(P,-1.0D0,V(1,L),1) 580 CONTINUE C C ORDER THE SINGULAR VALUE. C 590 IF (L .EQ. MM) GO TO 600 C ...EXIT IF (S(L) .GE. S(L+1)) GO TO 600 T = S(L) S(L) = S(L+1) S(L+1) = T IF (WANTV .AND. L .LT. P) * CALL DSWAP(P,V(1,L),1,V(1,L+1),1) IF (WANTU .AND. L .LT. N) * CALL DSWAP(N,U(1,L),1,U(1,L+1),1) L = L + 1 GO TO 590 600 CONTINUE ITER = 0 M = M - 1 610 CONTINUE GO TO 360 620 CONTINUE RETURN END SUBROUTINE CSVDC(X,LDX,N,P,S,E,U,LDU,V,LDV,WORK,JOB,INFO) INTEGER LDX,N,P,LDU,LDV,JOB,INFO COMPLEX X(LDX,*),S(*),E(*),U(LDU,*),V(LDV,*),WORK(*) C C C CSVDC IS A SUBROUTINE TO REDUCE A COMPLEX NXP MATRIX X BY C UNITARY TRANSFORMATIONS U AND V TO DIAGONAL FORM. THE C DIAGONAL ELEMENTS S(I) ARE THE SINGULAR VALUES OF X. THE C COLUMNS OF U ARE THE CORRESPONDING LEFT SINGULAR VECTORS, C AND THE COLUMNS OF V THE RIGHT SINGULAR VECTORS. C C ON ENTRY C C X COMPLEX(LDX,P), WHERE LDX.GE.N. C X CONTAINS THE MATRIX WHOSE SINGULAR VALUE C DECOMPOSITION IS TO BE COMPUTED. X IS C DESTROYED BY CSVDC. C C LDX INTEGER. C LDX IS THE LEADING DIMENSION OF THE ARRAY X. C C N INTEGER. C N IS THE NUMBER OF ROWS OF THE MATRIX X. C C P INTEGER. C P IS THE NUMBER OF COLUMNS OF THE MATRIX X. C C LDU INTEGER. C LDU IS THE LEADING DIMENSION OF THE ARRAY U C (SEE BELOW). C C LDV INTEGER. C LDV IS THE LEADING DIMENSION OF THE ARRAY V C (SEE BELOW). C C WORK COMPLEX(N). C WORK IS A SCRATCH ARRAY. C C JOB INTEGER. C JOB CONTROLS THE COMPUTATION OF THE SINGULAR C VECTORS. IT HAS THE DECIMAL EXPANSION AB C WITH THE FOLLOWING MEANING C C A.EQ.0 DO NOT COMPUTE THE LEFT SINGULAR C VECTORS. C A.EQ.1 RETURN THE N LEFT SINGULAR VECTORS C IN U. C A.GE.2 RETURNS THE FIRST MIN(N,P) C LEFT SINGULAR VECTORS IN U. C B.EQ.0 DO NOT COMPUTE THE RIGHT SINGULAR C VECTORS. C B.EQ.1 RETURN THE RIGHT SINGULAR VECTORS C IN V. C C ON RETURN C C S COMPLEX(MM), WHERE MM=MIN(N+1,P). C THE FIRST MIN(N,P) ENTRIES OF S CONTAIN THE C SINGULAR VALUES OF X ARRANGED IN DESCENDING C ORDER OF MAGNITUDE. C C E COMPLEX(P). C E ORDINARILY CONTAINS ZEROS. HOWEVER SEE THE C DISCUSSION OF INFO FOR EXCEPTIONS. C C U COMPLEX(LDU,K), WHERE LDU.GE.N. IF JOBA.EQ.1 THEN C K.EQ.N, IF JOBA.GE.2 THEN C K.EQ.MIN(N,P). C U CONTAINS THE MATRIX OF LEFT SINGULAR VECTORS. C U IS NOT REFERENCED IF JOBA.EQ.0. IF N.LE.P C OR IF JOBA.GT.2, THEN U MAY BE IDENTIFIED WITH X C IN THE SUBROUTINE CALL. C C V COMPLEX(LDV,P), WHERE LDV.GE.P. C V CONTAINS THE MATRIX OF RIGHT SINGULAR VECTORS. C V IS NOT REFERENCED IF JOBB.EQ.0. IF P.LE.N, C THEN V MAY BE IDENTIFIED WHTH X IN THE C SUBROUTINE CALL. C C INFO INTEGER. C THE SINGULAR VALUES (AND THEIR CORRESPONDING C SINGULAR VECTORS) S(INFO+1),S(INFO+2),...,S(M) C ARE CORRECT (HERE M=MIN(N,P)). THUS IF C INFO.EQ.0, ALL THE SINGULAR VALUES AND THEIR C VECTORS ARE CORRECT. IN ANY EVENT, THE MATRIX C B = CTRANS(U)*X*V IS THE BIDIAGONAL MATRIX C WITH THE ELEMENTS OF S ON ITS DIAGONAL AND THE C ELEMENTS OF E ON ITS SUPER-DIAGONAL (CTRANS(U) C IS THE CONJUGATE-TRANSPOSE OF U). THUS THE C SINGULAR VALUES OF X AND B ARE THE SAME. C C LINPACK. THIS VERSION DATED 03/19/79 . C G.W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB. C C CSVDC USES THE FOLLOWING FUNCTIONS AND SUBPROGRAMS. C C EXTERNAL CSROT C BLAS CAXPY,CDOTC,CSCAL,CSWAP,SCNRM2,SROTG C FORTRAN ABS,AIMAG,AMAX1,CABS,CMPLX C FORTRAN CONJG,MAX0,MIN0,MOD,REAL,SQRT C C INTERNAL VARIABLES C INTEGER I,ITER,J,JOBU,K,KASE,KK,L,LL,LLS,LM1,LP1,LS,LU,M,MAXIT, * MM,MM1,MP1,NCT,NCTP1,NCU,NRT,NRTP1 COMPLEX CDOTC,T,R REAL B,C,CS,EL,EMM1,F,G,SCNRM2,SCALE,SHIFT,SL,SM,SN,SMM1,T1,TEST, * ZTEST LOGICAL WANTU,WANTV C COMPLEX CSIGN,ZDUM,ZDUM1,ZDUM2 REAL CABS1 CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM)) CSIGN(ZDUM1,ZDUM2) = CABS(ZDUM1)*(ZDUM2/CABS(ZDUM2)) C C SET THE MAXIMUM NUMBER OF ITERATIONS. C MAXIT = 30 C C DETERMINE WHAT IS TO BE COMPUTED. C WANTU = .FALSE. WANTV = .FALSE. JOBU = MOD(JOB,100)/10 NCU = N IF (JOBU .GT. 1) NCU = MIN0(N,P) IF (JOBU .NE. 0) WANTU = .TRUE. IF (MOD(JOB,10) .NE. 0) WANTV = .TRUE. C C REDUCE X TO BIDIAGONAL FORM, STORING THE DIAGONAL ELEMENTS C IN S AND THE SUPER-DIAGONAL ELEMENTS IN E. C INFO = 0 NCT = MIN0(N-1,P) NRT = MAX0(0,MIN0(P-2,N)) LU = MAX0(NCT,NRT) IF (LU .LT. 1) GO TO 170 DO 160 L = 1, LU LP1 = L + 1 IF (L .GT. NCT) GO TO 20 C C COMPUTE THE TRANSFORMATION FOR THE L-TH COLUMN AND C PLACE THE L-TH DIAGONAL IN S(L). C S(L) = CMPLX(SCNRM2(N-L+1,X(L,L),1),0.0E0) IF (CABS1(S(L)) .EQ. 0.0E0) GO TO 10 IF (CABS1(X(L,L)) .NE. 0.0E0) S(L) = CSIGN(S(L),X(L,L)) CALL CSCAL(N-L+1,1.0E0/S(L),X(L,L),1) X(L,L) = (1.0E0,0.0E0) + X(L,L) 10 CONTINUE S(L) = -S(L) 20 CONTINUE IF (P .LT. LP1) GO TO 50 DO 40 J = LP1, P IF (L .GT. NCT) GO TO 30 IF (CABS1(S(L)) .EQ. 0.0E0) GO TO 30 C C APPLY THE TRANSFORMATION. C T = -CDOTC(N-L+1,X(L,L),1,X(L,J),1)/X(L,L) CALL CAXPY(N-L+1,T,X(L,L),1,X(L,J),1) 30 CONTINUE C C PLACE THE L-TH ROW OF X INTO E FOR THE C SUBSEQUENT CALCULATION OF THE ROW TRANSFORMATION. C E(J) = CONJG(X(L,J)) 40 CONTINUE 50 CONTINUE IF (.NOT.WANTU .OR. L .GT. NCT) GO TO 70 C C PLACE THE TRANSFORMATION IN U FOR SUBSEQUENT BACK C MULTIPLICATION. C DO 60 I = L, N U(I,L) = X(I,L) 60 CONTINUE 70 CONTINUE IF (L .GT. NRT) GO TO 150 C C COMPUTE THE L-TH ROW TRANSFORMATION AND PLACE THE C L-TH SUPER-DIAGONAL IN E(L). C E(L) = CMPLX(SCNRM2(P-L,E(LP1),1),0.0E0) IF (CABS1(E(L)) .EQ. 0.0E0) GO TO 80 IF (CABS1(E(LP1)) .NE. 0.0E0) E(L) = CSIGN(E(L),E(LP1)) CALL CSCAL(P-L,1.0E0/E(L),E(LP1),1) E(LP1) = (1.0E0,0.0E0) + E(LP1) 80 CONTINUE E(L) = -CONJG(E(L)) IF (LP1 .GT. N .OR. CABS1(E(L)) .EQ. 0.0E0) GO TO 120 C C APPLY THE TRANSFORMATION. C DO 90 I = LP1, N WORK(I) = (0.0E0,0.0E0) 90 CONTINUE DO 100 J = LP1, P CALL CAXPY(N-L,E(J),X(LP1,J),1,WORK(LP1),1) 100 CONTINUE DO 110 J = LP1, P CALL CAXPY(N-L,CONJG(-E(J)/E(LP1)),WORK(LP1),1, * X(LP1,J),1) 110 CONTINUE 120 CONTINUE IF (.NOT.WANTV) GO TO 140 C C PLACE THE TRANSFORMATION IN V FOR SUBSEQUENT C BACK MULTIPLICATION. C DO 130 I = LP1, P V(I,L) = E(I) 130 CONTINUE 140 CONTINUE 150 CONTINUE 160 CONTINUE 170 CONTINUE C C SET UP THE FINAL BIDIAGONAL MATRIX OF ORDER M. C M = MIN0(P,N+1) NCTP1 = NCT + 1 NRTP1 = NRT + 1 IF (NCT .LT. P) S(NCTP1) = X(NCTP1,NCTP1) IF (N .LT. M) S(M) = (0.0E0,0.0E0) IF (NRTP1 .LT. M) E(NRTP1) = X(NRTP1,M) E(M) = (0.0E0,0.0E0) C C IF REQUIRED, GENERATE U. C IF (.NOT.WANTU) GO TO 300 IF (NCU .LT. NCTP1) GO TO 200 DO 190 J = NCTP1, NCU DO 180 I = 1, N U(I,J) = (0.0E0,0.0E0) 180 CONTINUE U(J,J) = (1.0E0,0.0E0) 190 CONTINUE 200 CONTINUE IF (NCT .LT. 1) GO TO 290 DO 280 LL = 1, NCT L = NCT - LL + 1 IF (CABS1(S(L)) .EQ. 0.0E0) GO TO 250 LP1 = L + 1 IF (NCU .LT. LP1) GO TO 220 DO 210 J = LP1, NCU T = -CDOTC(N-L+1,U(L,L),1,U(L,J),1)/U(L,L) CALL CAXPY(N-L+1,T,U(L,L),1,U(L,J),1) 210 CONTINUE 220 CONTINUE CALL CSCAL(N-L+1,(-1.0E0,0.0E0),U(L,L),1) U(L,L) = (1.0E0,0.0E0) + U(L,L) LM1 = L - 1 IF (LM1 .LT. 1) GO TO 240 DO 230 I = 1, LM1 U(I,L) = (0.0E0,0.0E0) 230 CONTINUE 240 CONTINUE GO TO 270 250 CONTINUE DO 260 I = 1, N U(I,L) = (0.0E0,0.0E0) 260 CONTINUE U(L,L) = (1.0E0,0.0E0) 270 CONTINUE 280 CONTINUE 290 CONTINUE 300 CONTINUE C C IF IT IS REQUIRED, GENERATE V. C IF (.NOT.WANTV) GO TO 350 DO 340 LL = 1, P L = P - LL + 1 LP1 = L + 1 IF (L .GT. NRT) GO TO 320 IF (CABS1(E(L)) .EQ. 0.0E0) GO TO 320 DO 310 J = LP1, P T = -CDOTC(P-L,V(LP1,L),1,V(LP1,J),1)/V(LP1,L) CALL CAXPY(P-L,T,V(LP1,L),1,V(LP1,J),1) 310 CONTINUE 320 CONTINUE DO 330 I = 1, P V(I,L) = (0.0E0,0.0E0) 330 CONTINUE V(L,L) = (1.0E0,0.0E0) 340 CONTINUE 350 CONTINUE C C TRANSFORM S AND E SO THAT THEY ARE REAL. C DO 380 I = 1, M IF (CABS1(S(I)) .EQ. 0.0E0) GO TO 360 T = CMPLX(CABS(S(I)),0.0E0) R = S(I)/T S(I) = T IF (I .LT. M) E(I) = E(I)/R IF (WANTU) CALL CSCAL(N,R,U(1,I),1) 360 CONTINUE C ...EXIT IF (I .EQ. M) GO TO 390 IF (CABS1(E(I)) .EQ. 0.0E0) GO TO 370 T = CMPLX(CABS(E(I)),0.0E0) R = T/E(I) E(I) = T S(I+1) = S(I+1)*R IF (WANTV) CALL CSCAL(P,R,V(1,I+1),1) 370 CONTINUE 380 CONTINUE 390 CONTINUE C C MAIN ITERATION LOOP FOR THE SINGULAR VALUES. C MM = M ITER = 0 400 CONTINUE C C QUIT IF ALL THE SINGULAR VALUES HAVE BEEN FOUND. C C ...EXIT IF (M .EQ. 0) GO TO 660 C C IF TOO MANY ITERATIONS HAVE BEEN PERFORMED, SET C FLAG AND RETURN. C IF (ITER .LT. MAXIT) GO TO 410 INFO = M C ......EXIT GO TO 660 410 CONTINUE C C THIS SECTION OF THE PROGRAM INSPECTS FOR C NEGLIGIBLE ELEMENTS IN THE S AND E ARRAYS. ON C COMPLETION THE VARIABLES KASE AND L ARE SET AS FOLLOWS. C C KASE = 1 IF S(M) AND E(L-1) ARE NEGLIGIBLE AND L.LT.M C KASE = 2 IF S(L) IS NEGLIGIBLE AND L.LT.M C KASE = 3 IF E(L-1) IS NEGLIGIBLE, L.LT.M, AND C S(L), ..., S(M) ARE NOT NEGLIGIBLE (QR STEP). C KASE = 4 IF E(M-1) IS NEGLIGIBLE (CONVERGENCE). C DO 430 LL = 1, M L = M - LL C ...EXIT IF (L .EQ. 0) GO TO 440 TEST = CABS(S(L)) + CABS(S(L+1)) ZTEST = TEST + CABS(E(L)) IF (ZTEST .NE. TEST) GO TO 420 E(L) = (0.0E0,0.0E0) C ......EXIT GO TO 440 420 CONTINUE 430 CONTINUE 440 CONTINUE IF (L .NE. M - 1) GO TO 450 KASE = 4 GO TO 520 450 CONTINUE LP1 = L + 1 MP1 = M + 1 DO 470 LLS = LP1, MP1 LS = M - LLS + LP1 C ...EXIT IF (LS .EQ. L) GO TO 480 TEST = 0.0E0 IF (LS .NE. M) TEST = TEST + CABS(E(LS)) IF (LS .NE. L + 1) TEST = TEST + CABS(E(LS-1)) ZTEST = TEST + CABS(S(LS)) IF (ZTEST .NE. TEST) GO TO 460 S(LS) = (0.0E0,0.0E0) C ......EXIT GO TO 480 460 CONTINUE 470 CONTINUE 480 CONTINUE IF (LS .NE. L) GO TO 490 KASE = 3 GO TO 510 490 CONTINUE IF (LS .NE. M) GO TO 500 KASE = 1 GO TO 510 500 CONTINUE KASE = 2 L = LS 510 CONTINUE 520 CONTINUE L = L + 1 C C PERFORM THE TASK INDICATED BY KASE. C GO TO (530, 560, 580, 610), KASE C C DEFLATE NEGLIGIBLE S(M). C 530 CONTINUE MM1 = M - 1 F = REAL(E(M-1)) E(M-1) = (0.0E0,0.0E0) DO 550 KK = L, MM1 K = MM1 - KK + L T1 = REAL(S(K)) CALL SROTG(T1,F,CS,SN) S(K) = CMPLX(T1,0.0E0) IF (K .EQ. L) GO TO 540 F = -SN*REAL(E(K-1)) E(K-1) = CS*E(K-1) 540 CONTINUE IF (WANTV) CALL CSROT(P,V(1,K),1,V(1,M),1,CS,SN) 550 CONTINUE GO TO 650 C C SPLIT AT NEGLIGIBLE S(L). C 560 CONTINUE F = REAL(E(L-1)) E(L-1) = (0.0E0,0.0E0) DO 570 K = L, M T1 = REAL(S(K)) CALL SROTG(T1,F,CS,SN) S(K) = CMPLX(T1,0.0E0) F = -SN*REAL(E(K)) E(K) = CS*E(K) IF (WANTU) CALL CSROT(N,U(1,K),1,U(1,L-1),1,CS,SN) 570 CONTINUE GO TO 650 C C PERFORM ONE QR STEP. C 580 CONTINUE C C CALCULATE THE SHIFT. C SCALE = AMAX1(CABS(S(M)),CABS(S(M-1)),CABS(E(M-1)), * CABS(S(L)),CABS(E(L))) SM = REAL(S(M))/SCALE SMM1 = REAL(S(M-1))/SCALE EMM1 = REAL(E(M-1))/SCALE SL = REAL(S(L))/SCALE EL = REAL(E(L))/SCALE B = ((SMM1 + SM)*(SMM1 - SM) + EMM1**2)/2.0E0 C = (SM*EMM1)**2 SHIFT = 0.0E0 IF (B .EQ. 0.0E0 .AND. C .EQ. 0.0E0) GO TO 590 SHIFT = SQRT(B**2+C) IF (B .LT. 0.0E0) SHIFT = -SHIFT SHIFT = C/(B + SHIFT) 590 CONTINUE F = (SL + SM)*(SL - SM) - SHIFT G = SL*EL C C CHASE ZEROS. C MM1 = M - 1 DO 600 K = L, MM1 CALL SROTG(F,G,CS,SN) IF (K .NE. L) E(K-1) = CMPLX(F,0.0E0) F = CS*REAL(S(K)) + SN*REAL(E(K)) E(K) = CS*E(K) - SN*S(K) G = SN*REAL(S(K+1)) S(K+1) = CS*S(K+1) IF (WANTV) CALL CSROT(P,V(1,K),1,V(1,K+1),1,CS,SN) CALL SROTG(F,G,CS,SN) S(K) = CMPLX(F,0.0E0) F = CS*REAL(E(K)) + SN*REAL(S(K+1)) S(K+1) = -SN*E(K) + CS*S(K+1) G = SN*REAL(E(K+1)) E(K+1) = CS*E(K+1) IF (WANTU .AND. K .LT. N) * CALL CSROT(N,U(1,K),1,U(1,K+1),1,CS,SN) 600 CONTINUE E(M-1) = CMPLX(F,0.0E0) ITER = ITER + 1 GO TO 650 C C CONVERGENCE. C 610 CONTINUE C C MAKE THE SINGULAR VALUE POSITIVE C IF (REAL(S(L)) .GE. 0.0E0) GO TO 620 S(L) = -S(L) IF (WANTV) CALL CSCAL(P,(-1.0E0,0.0E0),V(1,L),1) 620 CONTINUE C C ORDER THE SINGULAR VALUE. C 630 IF (L .EQ. MM) GO TO 640 C ...EXIT IF (REAL(S(L)) .GE. REAL(S(L+1))) GO TO 640 T = S(L) S(L) = S(L+1) S(L+1) = T IF (WANTV .AND. L .LT. P) * CALL CSWAP(P,V(1,L),1,V(1,L+1),1) IF (WANTU .AND. L .LT. N) * CALL CSWAP(N,U(1,L),1,U(1,L+1),1) L = L + 1 GO TO 630 640 CONTINUE ITER = 0 M = M - 1 650 CONTINUE GO TO 400 660 CONTINUE RETURN END FUNCTION DET(A,KA,N,X) C ------------------- C EVALUATION OF THE DETERMINANT OF A-XI WHERE A IS AN NXN MATRIX, C X IS A SCALAR, AND I IS THE NXN IDENTITY MATRIX. C ------------------- C KA IS THE ROW DIMENSION OF A IN THE CALLING PROGRAM. IT IS C ASSUMED THAT KA IS GREATER THAN OR EQUAL TO N. C ------------------- DIMENSION A(KA,N) IF (N .GE. 2) GO TO 10 DET = A(1,1)-X RETURN C C REPLACE A WITH A-XI C 10 IF (X .EQ. 0.0) GO TO 20 DO 11 K=1,N 11 A(K,K) = A(K,K)-X C C INITIALIZATION C 20 DET = 1.0 NM1 = N-1 DO 52 K=1,NM1 KP1 = K+1 C C SEARCH FOR THE K-TH PIVOT ELEMENT C S = ABS(A(K,K)) L = K DO 30 I=KP1,N C = ABS(A(I,K)) IF (S .GE. C) GO TO 30 S = C L = I 30 CONTINUE PIVOT = A(L,K) C C UPDATE THE CALCULATION OF DET C DET = DET*PIVOT IF (DET .EQ. 0.0) RETURN IF (K .EQ. L) GO TO 50 DET = -DET C C INTERCHANGING ROWS K AND L C DO 40 J=K,N C = A(K,J) A(K,J) = A(L,J) 40 A(L,J) = C C C REDUCTION OF THE NON-PIVOT ROWS C 50 DO 51 I=KP1,N C = A(I,K)/PIVOT DO 51 J=KP1,N 51 A(I,J) = A(I,J)-C*A(K,J) 52 CONTINUE C C FINAL DETERMINANT CALCULATION C DET = DET*A(N,N) RETURN END DOUBLE PRECISION FUNCTION DPDET(A,KA,N,X) C ------------------- C EVALUATION OF THE DETERMINANT OF A-XI WHERE A IS AN NXN MATRIX, C X IS A SCALAR, AND I IS THE NXN IDENTITY MATRIX. C ------------------- C KA IS THE ROW DIMENSION OF A IN THE CALLING PROGRAM. IT IS C ASSUMED THAT KA IS GREATER THAN OR EQUAL TO N. C ------------------- DOUBLE PRECISION A(KA,N),X DOUBLE PRECISION PIVOT,S,C IF (N .GE. 2) GO TO 10 DPDET = A(1,1) - X RETURN C C REPLACE A WITH A-XI C 10 IF (X .EQ. 0.D0) GO TO 20 DO 11 K=1,N 11 A(K,K) = A(K,K) - X C C INITIALIZATION C 20 DPDET = 1.D0 NM1 = N - 1 DO 52 K=1,NM1 KP1 = K + 1 C C SEARCH FOR THE K-TH PIVOT ELEMENT C S = DABS(A(K,K)) L = K DO 30 I=KP1,N C = DABS(A(I,K)) IF (S .GE. C) GO TO 30 S = C L = I 30 CONTINUE PIVOT = A(L,K) C C UPDATE THE CALCULATION OF DET C DPDET = DPDET*PIVOT IF (DPDET .EQ. 0.D0) RETURN IF (K .EQ. L) GO TO 50 DPDET = -DPDET C C INTERCHANGING ROWS K AND L C DO 40 J=K,N C = A(K,J) A(K,J) = A(L,J) 40 A(L,J) = C C C REDUCTION OF THE NON-PIVOT ROWS C 50 DO 51 I=KP1,N C = A(I,K)/PIVOT DO 51 J=KP1,N 51 A(I,J) = A(I,J) - C*A(K,J) 52 CONTINUE C C FINAL DETERMINANT CALCULATION C DPDET = DPDET*A(N,N) RETURN END COMPLEX FUNCTION CDET(A,KA,N,X) C ------------------- C EVALUATION OF THE DETERMINANT OF A-XI WHERE A IS AN NXN MATRIX, C X IS A SCALAR, AND I IS THE NXN IDENTITY MATRIX. C ------------------- C KA IS THE ROW DIMENSION OF A IN THE CALLING PROGRAM. IT IS C ASSUMED THAT KA IS GREATER THAN OR EQUAL TO N. C ------------------- COMPLEX A(KA,N),X COMPLEX PIVOT,T,ZERO REAL S,C DATA ZERO/(0.0,0.0)/ C IF (N .GE. 2) GO TO 10 CDET = A(1,1)-X RETURN C C REPLACE A WITH A-XI C 10 IF (X .EQ. ZERO) GO TO 20 DO 11 K=1,N 11 A(K,K) = A(K,K)-X C C INITIALIZATION C 20 CDET = (1.0,0.0) NM1 = N-1 DO 52 K=1,NM1 KP1 = K+1 C C SEARCH FOR THE K-TH PIVOT ELEMENT C S = ABS(REAL(A(K,K))) + ABS(AIMAG(A(K,K))) L = K DO 30 I=KP1,N C = ABS(REAL(A(I,K))) + ABS(AIMAG(A(I,K))) IF (S .GE. C) GO TO 30 S = C L = I 30 CONTINUE PIVOT = A(L,K) C C UPDATE THE CALCULATION OF CDET C CDET = CDET*PIVOT IF (CDET .EQ. ZERO) RETURN IF (K .EQ. L) GO TO 50 CDET = -CDET C C INTERCHANGING ROWS K AND L C DO 40 J=K,N T = A(K,J) A(K,J) = A(L,J) 40 A(L,J) = T C C REDUCTION OF THE NON-PIVOT ROWS C 50 DO 51 I=KP1,N T = A(I,K)/PIVOT DO 51 J=KP1,N 51 A(I,J) = A(I,J)-T*A(K,J) 52 CONTINUE C C FINAL DETERMINANT CALCULATION C CDET = CDET*A(N,N) RETURN END SUBROUTINE ABSLV (MO,M,N,A,NA,B,NB,C,NC,WK,IERR) REAL A(NA,M), B(NB,N), C(NC,N), WK(*) C ---------------------------------------------------------------------- C ABSLV SOLVES THE REAL MATRIX EQUATION AX + XB = C. A IS REDUCED C TO LOWER SCHUR FORM, B IS REDUCED TO UPPER SCHUR FORM, AND THE C TRANSFORMED SYSTEM IS SOLVED BY BACK SUBSTITUTION. C ---------------------------------------------------------------------- C MO IS AN INPUT ARGUMENT WHICH SPECIFIES IF THE ROUTINE IS C BEING CALLED FOR THE FIRST TIME. ON AN INITIAL CALL MO = 0 AND C WE HAVE THE FOLLOWING SETUP. C C A(NA,M) C A IS A MATRIX OF ORDER M. IT IS ASSUMED THAT C NA .GE. M .GE. 1. C C B(NB,N) C B IS A MATRIX OF ORDER N. IT IS ASSUMED THAT C NB .GE. N .GE. 1. C C C(NC,N) C C IS A MATRIX HAVING M ROWS AND N COLUMNS. C IT IS ASSUMED THAT NC .GE. M. C C WK(---) C WK IS AN ARRAY OF DIMENSION M**2 + N**2 + 2K C WHERE K = MAX(M,N). WK IS A GENERAL STORAGE C AREA FOR THE ROUTINE. C C IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS. WHEN C THE ROUTINE TERMINATES, IERR HAS ONE OF THE FOLLOWING VALUES... C C IERR = 0 THE SOLUTION WAS OBTAINED AND STORED IN C. C IERR = 1 THE EQUATIONS ARE INCONSISTENT FOR A AND B. C THE PROBLEM CANNOT BE SOLVED. C IERR = -1 A COULD NOT BE REDUCED TO LOWER SCHUR FORM. C THE PROBLEM CANNOT BE SOLVED. C IERR = -2 B COULD NOT BE REDUCED TO UPPER SCHUR FORM. C THE PROBLEM CANNOT BE SOLVED. C C WHEN IERR = 0, A CONTAINS THE LOWER SCHUR FORM OF THE MATRIX A, C B CONTAINS THE UPPER SCHUR FORM OF THE MATRIX B, AND WK CONTAINS C THE ORTHONAL MATRICES INVOLVED IN THE SCHUR DECOMPOSITIONS OF C A AND B. THIS INFORMATION CAN BE REUSED TO SOLVE A NEW SET OF C EQUATIONS AX + XB = C WITHOUT HAVING TO REDECOMPOSE A AND B. C THE FOLLOWING OPTIONS ARE AVAILABLE... C C MO = 1 NEW MATRICES A AND C ARE GIVEN. THE DATA FOR B C IS REUSED IN SOLVING THE NEW SET OF EQUATIONS. C C MO = 2 NEW MATRICES B AND C ARE GIVEN. THE DATA FOR A C IS REUSED IN SOLVING THE NEW SET OF EQUATIONS. C C MO .NE. 0,1,2 A NEW MATRIX C IS GIVEN. THE DATA FOR A AND B C IS REUSED IN SOLVING THE NEW SET OF EQUATIONS. C C WHEN ABSLV IS RECALLED, IT IS ASSUMED THAT M, N, AND WK HAVE C NOT BEEN MODIFIED. C ---------------------------------------------------------------------- C THIS SUBROUTINE IS A MODIFICATION BY C ALFRED H. MORRIS, JR. C NAVAL SURFACE WEAPONS CENTER C DAHLGREN, VIRGINIA C OF THE SUBROUTINE AXPXB WRITTEN BY C R.H. BARTELS AND G.W.STEWART C UNIVERSITY OF TEXAS AT AUSTIN. C C REFERENCE. BARTELS, R.H. AND STEWART, G.W., ALGORITHM 432, C SOLUTION OF THE MATRIX EQUATION AX + XB = C, COMM. ACM C 15 (1972), PP. 820-826. C ---------------------------------------------------------------------- IU = 1 IV = M*M + 1 IW = N*N + IV CALL ABSLV1 (MO,M,N,A,NA,WK(IU),M,B,NB,WK(IV),N, * C,NC,WK(IW),IERR) RETURN END SUBROUTINE ABSLV1 (MO,M,N,A,NA,U,NU,B,NB,V,NV,C,NC,WK,IERR) C ---------------------------------------------------------------------- C ABSLV1 SOLVES THE REAL MATRIX EQUATION AX + XB = C. A IS REDUCED C TO LOWER SCHUR FORM, B IS REDUCED TO UPPER SCHUR FORM, AND THE C TRANSFORMED SYSTEM IS SOLVED BY BACK SUBSTITUTION. C ---------------------------------------------------------------------- REAL A(NA,M), B(NB,N), C(NC,N) REAL U(NU,M), V(NV,N), TEMP, WK(*) C C IF REQUIRED, REDUCE A TO LOWER REAL SCHUR FORM C IF (MO .NE. 0 .AND. MO .NE. 1) GO TO 35 DO 11 I = 1,M DO 10 J = I,M TEMP = A(I,J) A(I,J) = A(J,I) A(J,I) = TEMP 10 CONTINUE 11 CONTINUE CALL ORTHES (NA,M,1,M,A,WK) CALL ORTRN1 (M,1,M,A,NA,U,NU,WK) C IF (M .EQ. 1) GO TO 20 CALL SCHUR (M,1,M,A,NA,U,NU,WK(1),WK(M+1),IERR) IF (IERR .NE. 0) GO TO 200 C 20 DO 31 I = 1,M DO 30 J = I,M TEMP = A(I,J) A(I,J) = A(J,I) A(J,I) = TEMP 30 CONTINUE 31 CONTINUE C C IF REQUIRED, REDUCE B TO UPPER REAL SCHUR FORM C 35 IF (MO .NE. 0 .AND. MO .NE. 2) GO TO 45 CALL ORTHES (NB,N,1,N,B,WK) CALL ORTRN1 (N,1,N,B,NB,V,NV,WK) C IF (N .EQ. 1) GO TO 45 CALL SCHUR (N,1,N,B,NB,V,NV,WK(1),WK(N+1),IERR) IF (IERR .NE. 0) GO TO 210 C C TRANSFORM C C 45 DO 61 J = 1,N DO 51 I = 1,M WK(I) = 0.0 DO 50 K = 1,M WK(I) = WK(I) + U(K,I)*C(K,J) 50 CONTINUE 51 CONTINUE DO 60 I = 1,M C(I,J) = WK(I) 60 CONTINUE 61 CONTINUE C DO 81 I = 1,M DO 71 J = 1,N WK(J) = 0.0 DO 70 K = 1,N WK(J) = WK(J) + C(I,K)*V(K,J) 70 CONTINUE 71 CONTINUE DO 80 J = 1,N C(I,J) = WK(J) 80 CONTINUE 81 CONTINUE C C SOLVE THE TRANSFORMED SYSTEM C CALL SHRSLV (A,B,C,M,N,NA,NB,NC,IERR) IF (IERR .NE. 0) GO TO 220 C C TRANSFORM C BACK TO THE SOLUTION C DO 101 J = 1,N DO 91 I = 1,M WK(I) = 0.0 DO 90 K = 1,M WK(I) = WK(I) + U(I,K)*C(K,J) 90 CONTINUE 91 CONTINUE DO 100 I = 1,M C(I,J) = WK(I) 100 CONTINUE 101 CONTINUE C DO 121 I = 1,M DO 111 J = 1,N WK(J) = 0.0 DO 110 K = 1,N WK(J) = WK(J) + C(I,K)*V(J,K) 110 CONTINUE 111 CONTINUE DO 120 J = 1,N C(I,J) = WK(J) 120 CONTINUE 121 CONTINUE RETURN C C ERROR RETURN C 200 IERR = -1 RETURN 210 IERR = -2 RETURN 220 IERR = 1 RETURN END SUBROUTINE SCHUR (N, LOW, IGH, H, NH, Z, NZ, WR, WI, IERR) C ---------------------------------------------------------------------- C IT IS ASSUMED THAT H IS AN UPPER HESSENBERG MATRIX. SCHUR C OBTAINS AN ORTHOGONAL MATRIX Q FOR WHICH TRANSPOSE(Q)*H*Q C IS IN SCHUR FORM. THE EIGENVALUES OF H ARE ALSO COMPUTED. C C ON INPUT- C C N IS THE ORDER OF THE MATRIX, C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, C SET LOW=1, IGH=N, (BALANC IS AN EISPACK SUBROUTINE). C C H CONTAINS THE UPPER HESSENBERG MATRIX, C C NH IS THE FIRST DIMENSION OF H, C C Z CONTAINS A MATRIX OF ORDER N, C C NZ IS THE FIRST DIMENSION OF Z. C C ON OUTPUT- C C H CONTAINS THE TRANSFORMED MATRIX IN UPPER SCHUR FORM, C C Z CONTAINS THE MATRIX Z*Q WHERE Q IS THE ORTHOGONAL C MATRIX WHICH REDUCES H TO UPPER SCHUR FORM, C C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE EIGENVALUES. THE EIGENVALUES C ARE UNORDERED EXCEPT THAT COMPLEX CONJUGATE PAIRS C OF VALUES APPEAR CONSECUTIVELY WITH THE EIGENVALUE C HAVING THE POSITIVE IMAGINARY PART FIRST. IF AN C ERROR EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT C FOR INDICES IERR+1,...,N. C C IERR IS SET TO C 0 FOR NORMAL RETURN, C J IF THE J-TH EIGENVALUE HAS NOT BEEN C DETERMINED AFTER 30 ITERATIONS. C C ----------------- C WRITTEN BY JACK DONGARRA C ARGONNE NATIONAL LABORATORY C MAY 1961 C MODIFIED BY A.H. MORRIS (NSWC) C ---------------------------------------------------------------------- C THIS SUBROUTINE IS A MODIFICATION OF THE EISPACK SUBROUTINE C HQR2, WHICH IS BASED ON THE ALGOL PROCEDURE HQR BY PETERS C AND WILKINSON, NUM. MATH. 16 (1970), PP.181-204. C ---------------------------------------------------------------------- INTEGER I, J, K, L, M, N, EN, LL, MM, NA, NH, NZ, IGH, ITS, LOW, * MP2, ENM2, IERR REAL H(NH,N), WR(N), WI(N), Z(NZ,N) REAL P, Q, R, S, T, W, X, Y, ZZ, NORM, S1, S2 LOGICAL NOTLAS C REAL SQRT, ABS C INTEGER MIN0 C IERR = 0 NORM = 0.0 K = 1 C ********** STORE ROOTS ISOLATED BY BALANC C AND COMPUTE MATRIX NORM ********** DO 20 I = 1,N C DO 10 J = K,N NORM = NORM + ABS(H(I,J)) 10 CONTINUE C K = I IF (I .GE. LOW .AND. I .LE. IGH) GO TO 20 WR(I) = H(I,I) WI(I) = 0.0 20 CONTINUE C EN = IGH T = 0.0 C ********** SEARCH FOR NEXT EIGENVALUES ********** 30 IF (EN .LT. LOW) GO TO 300 ITS = 0 NA = EN - 1 ENM2 = NA - 1 C ********** LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT C FOR L=EN STEP -1 UNTIL LOW DO -- ********** 40 DO 50 LL = LOW,EN L = EN + LOW - LL IF (L .EQ. LOW) GO TO 60 S = ABS(H(L-1,L-1)) + ABS(H(L,L)) IF (S .EQ. 0.0) S = NORM S1 = S S2 = S1 + ABS(H(L,L-1)) IF (S1 .EQ. S2) GO TO 60 50 CONTINUE C ********** FORM SHIFT ********** 60 X = H(EN,EN) IF (L .EQ. EN) GO TO 220 Y = H(NA,NA) W = H(EN,NA)*H(NA,EN) IF (L .EQ .NA) GO TO 230 IF (ITS .EQ. 30) GO TO 290 IF (ITS .NE. 10 .AND. ITS .NE. 20) GO TO 80 C ********** FORM EXCEPTIONAL SHIFT ********** T = T + X C DO 70 I = LOW,EN H(I,I) = H(I,I) - X 70 CONTINUE C S = ABS(H(EN,NA)) + ABS(H(NA,ENM2)) X = 0.75*S Y = X W = -0.4375*S*S 80 ITS = ITS + 1 C ********** LOOK FOR TWO CONSECUTIVE SMALL C SUB-DIAGONAL ELEMENTS. C FOR M=EN-2 STEP -1 UNTIL L DO -- ********** DO 90 MM = L,ENM2 M = ENM2 + L - MM ZZ = H(M,M) R = X - ZZ S = Y - ZZ P = (R*S-W)/H(M+1,M) + H(M,M+1) Q = H(M+1,M+1) - ZZ - R - S R = H(M+2,M+1) S = ABS(P) + ABS(Q) + ABS(R) P = P/S Q = Q/S R = R/S IF (M .EQ. L) GO TO 100 S1 = ABS(P)*(ABS(H(M-1,M-1))+ABS(ZZ)+ABS(H(M+1,M+1))) S2 = S1 + ABS(H(M,M-1))*(ABS(Q) + ABS(R)) IF (S1 .EQ. S2) GO TO 100 90 CONTINUE C 100 MP2 = M + 2 C DO 110 I = MP2,EN H(I,I-2) = 0.0 IF (I .EQ. MP2) GO TO 110 H(I,I-3) = 0.0 110 CONTINUE C ********** DOUBLE QR STEP INVOLVING ROWS L TO EN AND C COLUMNS M TO EN ********** DO 210 K = M,NA NOTLAS = K.NE.NA IF (K .EQ. M) GO TO 120 P = H(K,K-1) Q = H(K+1,K-1) R = 0.0 IF (NOTLAS) R = H(K+2,K-1) X = ABS(P) + ABS(Q) + ABS(R) IF (X .EQ. 0.0) GO TO 210 P = P/X Q = Q/X R = R/X 120 S = SQRT(P*P + Q*Q + R*R) IF (P .LT. 0.0) S = -S IF (K .EQ. M) GO TO 130 H(K,K-1) = -S*X GO TO 140 130 IF (L .NE. M) H(K,K-1) = -H(K,K-1) 140 P = P + S X = P/S Y = Q/S ZZ = R/S Q = Q/P R = R/P C ********** ROW MODIFICATION ********** DO 160 J = K,N P = H(K,J) + Q*H(K+1,J) IF (.NOT.NOTLAS) GO TO 150 P = P + R*H(K+2,J) H(K+2,J) = H(K+2,J) - P*ZZ 150 H(K+1,J) = H(K+1,J) - P*Y H(K,J) = H(K,J) - P*X 160 CONTINUE C J = MIN0(EN,K+3) C ********** COLUMN MODIFICATION ********** DO 180 I = 1,J P = X*H(I,K) + Y*H(I,K+1) IF (.NOT.NOTLAS) GO TO 170 P = P + ZZ*H(I,K+2) H(I,K+2) = H(I,K+2) - P*R 170 H(I,K+1) = H(I,K+1) - P*Q H(I,K) = H(I,K) - P 180 CONTINUE C ********** ACCUMULATE TRANSFORMATIONS ********** DO 200 I = LOW,IGH P = X*Z(I,K) + Y*Z(I,K+1) IF (.NOT.NOTLAS) GO TO 190 P = P + ZZ*Z(I,K+2) Z(I,K+2) = Z(I,K+2) - P*R 190 Z(I,K+1) = Z(I,K+1) - P*Q Z(I,K) = Z(I,K) - P 200 CONTINUE C 210 CONTINUE C GO TO 40 C ********** ONE ROOT FOUND ********** 220 H(EN,EN) = X + T WR(EN) = H(EN,EN) WI(EN) = 0.0 EN = NA GO TO 30 C ********** TWO ROOTS FOUND ********** 230 P = (Y - X)/2.0 Q = P*P + W ZZ = SQRT(ABS(Q)) H(EN,EN) = X + T X = H(EN,EN) H(NA,NA) = Y + T IF (Q .LT. 0.0) GO TO 270 C ********** REAL PAIR ********** IF (P .LT. 0.0) ZZ = -ZZ ZZ = P + ZZ WR(NA) = X + ZZ WR(EN) = WR(NA) IF (ZZ .NE. 0.0) WR(EN) = X - W/ZZ WI(NA) = 0.0 WI(EN) = 0.0 X = H(EN,NA) S = ABS(X) + ABS(ZZ) P = X/S Q = ZZ/S R = SQRT(P*P + Q*Q) P = P/R Q = Q/R C ********** ROW MODIFICATION ********** DO 240 J = NA,N ZZ = H(NA,J) H(NA,J) = Q*ZZ + P*H(EN,J) H(EN,J) = Q*H(EN,J) - P*ZZ 240 CONTINUE C ********** COLUMN MODIFICATION ********** DO 250 I = 1,EN ZZ = H(I,NA) H(I,NA) = Q*ZZ + P*H(I,EN) H(I,EN) = Q*H(I,EN) - P*ZZ 250 CONTINUE C ********** ACCUMULATE TRANSFORMATIONS ********** DO 260 I = LOW,IGH ZZ = Z(I,NA) Z(I,NA) = Q*ZZ + P*Z(I,EN) Z(I,EN) = Q*Z(I,EN) - P*ZZ 260 CONTINUE C GO TO 280 C ********** COMPLEX PAIR ********** 270 WR(NA) = X + P WR(EN) = X + P WI(NA) = ZZ WI(EN) = -ZZ 280 EN = ENM2 GO TO 30 C ********** SET ERROR -- NO CONVERGENCE TO AN C EIGENVALUE AFTER 30 ITERATIONS ********** 290 IERR = EN RETURN 300 DO 320 I = 1,N IP1 = I + 1 IF (ABS(WI(I)) .NE. 0.0) IP1 = IP1 + 1 IF (IP1 .GT. N) GO TO 320 DO 310 J = IP1,N H(J,I) = 0.0 310 CONTINUE 320 CONTINUE RETURN END SUBROUTINE SHRSLV (A,B,C,M,N,NA,NB,NC,IERR) C ------------------------------------------------------------------ C SHRSLV SOLVES THE MATRIX EQUATION AX + XB = C WHERE C A IS IN LOWER SCHUR FORM AND B IN UPPER SCHUR FORM. C ------------------------------------------------------------------ INTEGER M,N,NA,NB,NC,IERR REAL A(NA,M), B(NB,N), C(NC,N) REAL SUM, P(4), T(4,4) INTEGER DK,DL,I,IB,J,JA,K,KM1,KK,L,LM1,LL C L = 1 10 LM1 = L - 1 DL = 1 IF (L .EQ. N) GO TO 15 IF (B(L+1,L) .NE. 0.0) DL = 2 15 LL = L + DL - 1 IF (L .EQ. 1) GO TO 30 C DO 22 J = L,LL DO 21 I = 1,M SUM = C(I,J) DO 20 IB = 1,LM1 20 SUM = SUM - C(I,IB)*B(IB,J) 21 C(I,J) = SUM 22 CONTINUE C 30 K = 1 40 KM1 = K - 1 DK = 1 IF (K .EQ. M) GO TO 45 IF (A(K,K+1) .NE. 0.0) DK = 2 45 KK = K + DK - 1 IF (K .EQ. 1) GO TO 60 C DO 52 I = K,KK DO 51 J = L,LL SUM = C(I,J) DO 50 JA = 1,KM1 50 SUM = SUM - A(I,JA)*C(JA,J) 51 C(I,J) = SUM 52 CONTINUE C 60 IF (DL .EQ. 2) GO TO 80 IF (DK .EQ. 2) GO TO 70 T(1,1) = A(K,K) + B(L,L) IF (T(1,1) .EQ. 0.0) GO TO 200 C(K,L) = C(K,L)/T(1,1) IERR = 0 GO TO 100 C 70 T(1,1) = A(K,K) + B(L,L) T(1,2) = A(K,KK) T(2,1) = A(KK,K) T(2,2) = A(KK,KK) + B(L,L) P(1) = C(K,L) P(2) = C(KK,L) CALL SLV (2, 1, T, 4, P, 4, IERR) IF (IERR .NE. 0) GO TO 200 C(K,L) = P(1) C(KK,L) = P(2) GO TO 100 C 80 IF (DK .EQ. 2) GO TO 90 T(1,1) = A(K,K) + B(L,L) T(1,2) = B(LL,L) T(2,1) = B(L,LL) T(2,2) = A(K,K) + B(LL,LL) P(1) = C(K,L) P(2) = C(K,LL) CALL SLV (2, 1, T, 4, P, 4, IERR) IF (IERR .NE. 0) GO TO 200 C(K,L) = P(1) C(K,LL) = P(2) GO TO 100 C 90 T(1,1) = A(K,K) + B(L,L) T(1,2) = A(K,KK) T(1,3) = B(LL,L) T(1,4) = 0.0 T(2,1) = A(KK,K) T(2,2) = A(KK,KK) + B(L,L) T(2,3) = 0.0 T(2,4) = T(1,3) T(3,1) = B(L,LL) T(3,2) = 0.0 T(3,3) = A(K,K) + B(LL,LL) T(3,4) = T(1,2) T(4,1) = 0.0 T(4,2) = T(3,1) T(4,3) = T(2,1) T(4,4) = A(KK,KK) + B(LL,LL) P(1) = C(K,L) P(2) = C(KK,L) P(3) = C(K,LL) P(4) = C(KK,LL) CALL SLV (4, 1, T, 4, P, 4, IERR) IF (IERR .NE. 0) GO TO 200 C(K,L) = P(1) C(KK,L) = P(2) C(K,LL) = P(3) C(KK,LL) = P(4) C 100 K = K + DK IF (K .LE. M) GO TO 40 L = L + DL IF (L .LE. N) GO TO 10 RETURN C C ERROR RETURN C 200 IERR = 1 RETURN END SUBROUTINE DABSLV (MO,M,N,A,NA,B,NB,C,NC,WK,IERR) DOUBLE PRECISION A(NA,M), B(NB,N), C(NC,N), WK(*) C ---------------------------------------------------------------------- C DABSLV SOLVES THE REAL MATRIX EQUATION AX + XB = C. A IS REDUCED C TO LOWER SCHUR FORM, B IS REDUCED TO UPPER SCHUR FORM, AND THE C TRANSFORMED SYSTEM IS SOLVED BY BACK SUBSTITUTION. C ---------------------------------------------------------------------- C MO IS AN INPUT ARGUMENT WHICH SPECIFIES IF THE ROUTINE IS C BEING CALLED FOR THE FIRST TIME. ON AN INITIAL CALL MO = 0 AND C WE HAVE THE FOLLOWING SETUP. C C A(NA,M) C A IS A MATRIX OF ORDER M. IT IS ASSUMED THAT C NA .GE. M .GE. 1. C C B(NB,N) C B IS A MATRIX OF ORDER N. IT IS ASSUMED THAT C NB .GE. N .GE. 1. C C C(NC,N) C C IS A MATRIX HAVING M ROWS AND N COLUMNS. C IT IS ASSUMED THAT NC .GE. M. C C WK(---) C WK IS AN ARRAY OF DIMENSION M**2 + N**2 + 2K C WHERE K = MAX(M,N). WK IS A GENERAL STORAGE C AREA FOR THE ROUTINE. C C IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS. WHEN C THE ROUTINE TERMINATES, IERR HAS ONE OF THE FOLLOWING VALUES... C C IERR = 0 THE SOLUTION WAS OBTAINED AND STORED IN C. C IERR = 1 THE EQUATIONS ARE INCONSISTENT FOR A AND B. C THE PROBLEM CANNOT BE SOLVED. C IERR = -1 A COULD NOT BE REDUCED TO LOWER SCHUR FORM. C THE PROBLEM CANNOT BE SOLVED. C IERR = -2 B COULD NOT BE REDUCED TO UPPER SCHUR FORM. C THE PROBLEM CANNOT BE SOLVED. C C WHEN IERR = 0, A CONTAINS THE LOWER SCHUR FORM OF THE MATRIX A, C B CONTAINS THE UPPER SCHUR FORM OF THE MATRIX B, AND WK CONTAINS C THE ORTHONAL MATRICES INVOLVED IN THE SCHUR DECOMPOSITIONS OF C A AND B. THIS INFORMATION CAN BE REUSED TO SOLVE A NEW SET OF C EQUATIONS AX + XB = C WITHOUT HAVING TO REDECOMPOSE A AND B. C THE FOLLOWING OPTIONS ARE AVAILABLE... C C MO = 1 NEW MATRICES A AND C ARE GIVEN. THE DATA FOR B C IS REUSED IN SOLVING THE NEW SET OF EQUATIONS. C C MO = 2 NEW MATRICES B AND C ARE GIVEN. THE DATA FOR A C IS REUSED IN SOLVING THE NEW SET OF EQUATIONS. C C MO .NE. 0,1,2 A NEW MATRIX C IS GIVEN. THE DATA FOR A AND B C IS REUSED IN SOLVING THE NEW SET OF EQUATIONS. C C WHEN DABSLV IS RECALLED, IT IS ASSUMED THAT M, N, AND WK HAVE C NOT BEEN MODIFIED. C ---------------------------------------------------------------------- C THIS SUBROUTINE IS A MODIFICATION BY C ALFRED H. MORRIS, JR. C NAVAL SURFACE WEAPONS CENTER C DAHLGREN, VIRGINIA C OF THE SUBROUTINE AXPXB WRITTEN BY C R.H. BARTELS AND G.W.STEWART C UNIVERSITY OF TEXAS AT AUSTIN. C C REFERENCE. BARTELS, R.H. AND STEWART, G.W., ALGORITHM 432, C SOLUTION OF THE MATRIX EQUATION AX + XB = C, COMM. ACM C 15 (1972), PP. 820-826. C ---------------------------------------------------------------------- IU = 1 IV = M*M + 1 IW = N*N + IV CALL DABSV1 (MO,M,N,A,NA,WK(IU),M,B,NB,WK(IV),N, * C,NC,WK(IW),IERR) RETURN END SUBROUTINE DABSV1 (MO,M,N,A,NA,U,NU,B,NB,V,NV,C,NC,WK,IERR) C ---------------------------------------------------------------------- C DABSV1 SOLVES THE REAL MATRIX EQUATION AX + XB = C. A IS REDUCED C TO LOWER SCHUR FORM, B IS REDUCED TO UPPER SCHUR FORM, AND THE C TRANSFORMED SYSTEM IS SOLVED BY BACK SUBSTITUTION. C ---------------------------------------------------------------------- DOUBLE PRECISION A(NA,M), B(NB,N), C(NC,N) DOUBLE PRECISION U(NU,M), V(NV,N), TEMP, WK(*) C C IF REQUIRED, REDUCE A TO LOWER REAL SCHUR FORM C IF (MO .NE. 0 .AND. MO .NE. 1) GO TO 35 DO 11 I = 1,M DO 10 J = I,M TEMP = A(I,J) A(I,J) = A(J,I) A(J,I) = TEMP 10 CONTINUE 11 CONTINUE CALL DORTH (NA,M,1,M,A,WK) CALL DRTRN1 (M,1,M,A,NA,U,NU,WK) C IF (M .EQ. 1) GO TO 20 CALL DSCHUR (M,1,M,A,NA,U,NU,WK(1),WK(M+1),IERR) IF (IERR .NE. 0) GO TO 200 C 20 DO 31 I = 1,M DO 30 J = I,M TEMP = A(I,J) A(I,J) = A(J,I) A(J,I) = TEMP 30 CONTINUE 31 CONTINUE C C IF REQUIRED, REDUCE B TO UPPER REAL SCHUR FORM C 35 IF (MO .NE. 0 .AND. MO .NE. 2) GO TO 45 CALL DORTH (NB,N,1,N,B,WK) CALL DRTRN1 (N,1,N,B,NB,V,NV,WK) C IF (N .EQ. 1) GO TO 45 CALL DSCHUR (N,1,N,B,NB,V,NV,WK(1),WK(N+1),IERR) IF (IERR .NE. 0) GO TO 210 C C TRANSFORM C C 45 DO 61 J = 1,N DO 51 I = 1,M WK(I) = 0.D0 DO 50 K = 1,M WK(I) = WK(I) + U(K,I)*C(K,J) 50 CONTINUE 51 CONTINUE DO 60 I = 1,M C(I,J) = WK(I) 60 CONTINUE 61 CONTINUE C DO 81 I = 1,M DO 71 J = 1,N WK(J) = 0.D0 DO 70 K = 1,N WK(J) = WK(J) + C(I,K)*V(K,J) 70 CONTINUE 71 CONTINUE DO 80 J = 1,N C(I,J) = WK(J) 80 CONTINUE 81 CONTINUE C C SOLVE THE TRANSFORMED SYSTEM C CALL DSHSLV (A,B,C,M,N,NA,NB,NC,IERR) IF (IERR .NE. 0) GO TO 220 C C TRANSFORM C BACK TO THE SOLUTION C DO 101 J = 1,N DO 91 I = 1,M WK(I) = 0.D0 DO 90 K = 1,M WK(I) = WK(I) + U(I,K)*C(K,J) 90 CONTINUE 91 CONTINUE DO 100 I = 1,M C(I,J) = WK(I) 100 CONTINUE 101 CONTINUE C DO 121 I = 1,M DO 111 J = 1,N WK(J) = 0.D0 DO 110 K = 1,N WK(J) = WK(J) + C(I,K)*V(J,K) 110 CONTINUE 111 CONTINUE DO 120 J = 1,N C(I,J) = WK(J) 120 CONTINUE 121 CONTINUE RETURN C C ERROR RETURN C 200 IERR = -1 RETURN 210 IERR = -2 RETURN 220 IERR = 1 RETURN END SUBROUTINE DSCHUR (N, LOW, IGH, H, NH, Z, NZ, WR, WI, IERR) C ---------------------------------------------------------------------- C IT IS ASSUMED THAT H IS AN UPPER HESSENBERG MATRIX. DSCHUR C OBTAINS AN ORTHOGONAL MATRIX Q FOR WHICH TRANSPOSE(Q)*H*Q C IS IN SCHUR FORM. THE EIGENVALUES OF H ARE ALSO COMPUTED. C C ON INPUT- C C N IS THE ORDER OF THE MATRIX, C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE DBAL. IF DBAL HAS NOT BEEN USED, SET C LOW = 1, IGH = N. C C H CONTAINS THE UPPER HESSENBERG MATRIX, C C NH IS THE FIRST DIMENSION OF H, C C Z CONTAINS A MATRIX OF ORDER N, C C NZ IS THE FIRST DIMENSION OF Z. C C ON OUTPUT- C C H CONTAINS THE TRANSFORMED MATRIX IN UPPER SCHUR FORM, C C Z CONTAINS THE MATRIX Z*Q WHERE Q IS THE ORTHOGONAL C MATRIX WHICH REDUCES H TO UPPER SCHUR FORM, C C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE EIGENVALUES. THE EIGENVALUES C ARE UNORDERED EXCEPT THAT COMPLEX CONJUGATE PAIRS C OF VALUES APPEAR CONSECUTIVELY WITH THE EIGENVALUE C HAVING THE POSITIVE IMAGINARY PART FIRST. IF AN C ERROR EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT C FOR INDICES IERR+1,...,N. C C IERR IS SET TO C 0 FOR NORMAL RETURN, C J IF THE J-TH EIGENVALUE HAS NOT BEEN C DETERMINED AFTER 50 ITERATIONS. C C ----------------- C WRITTEN BY JACK DONGARRA C ARGONNE NATIONAL LABORATORY C MAY 1961 C MODIFIED BY A.H. MORRIS (NSWC) C ---------------------------------------------------------------------- C THIS SUBROUTINE IS A MODIFICATION OF THE EISPACK SUBROUTINE C HQR2, WHICH IS BASED ON THE ALGOL PROCEDURE HQR BY PETERS C AND WILKINSON, NUM. MATH. 16 (1970), PP.181-204. C ---------------------------------------------------------------------- INTEGER I, J, K, L, M, N, EN, LL, MM, NA, NH, NZ, IGH, ITS, LOW, * MP2, ENM2, IERR DOUBLE PRECISION H(NH,N), WR(N), WI(N), Z(NZ,N) DOUBLE PRECISION P, Q, R, S, T, W, X, Y, ZZ, NORM, S1, S2 LOGICAL NOTLAS C DOUBLE PRECISION DSQRT, DABS C INTEGER MIN0 C IERR = 0 NORM = 0.D0 K = 1 C ********** STORE ROOTS ISOLATED BY BALANC C AND COMPUTE MATRIX NORM ********** DO 20 I = 1,N C DO 10 J = K,N NORM = NORM + DABS(H(I,J)) 10 CONTINUE C K = I IF (I .GE. LOW .AND. I .LE. IGH) GO TO 20 WR(I) = H(I,I) WI(I) = 0.D0 20 CONTINUE C EN = IGH T = 0.D0 C ********** SEARCH FOR NEXT EIGENVALUES ********** 30 IF (EN .LT. LOW) GO TO 300 ITS = 0 NA = EN - 1 ENM2 = NA - 1 C ********** LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT C FOR L=EN STEP -1 UNTIL LOW DO -- ********** 40 DO 50 LL = LOW,EN L = EN + LOW - LL IF (L .EQ. LOW) GO TO 60 S = DABS(H(L-1,L-1)) + DABS(H(L,L)) IF (S .EQ. 0.D0) S = NORM S1 = S S2 = S1 + DABS(H(L,L-1)) IF (S1 .EQ. S2) GO TO 60 50 CONTINUE C ********** FORM SHIFT ********** 60 X = H(EN,EN) IF (L .EQ. EN) GO TO 220 Y = H(NA,NA) W = H(EN,NA)*H(NA,EN) IF (L .EQ .NA) GO TO 230 IF (ITS .EQ. 50) GO TO 290 IF (ITS .NE. 10 .AND. ITS .NE. 20 .AND. ITS .NE. 30) GO TO 80 C ********** FORM EXCEPTIONAL SHIFT ********** T = T + X C DO 70 I = LOW,EN H(I,I) = H(I,I) - X 70 CONTINUE C S = DABS(H(EN,NA)) + DABS(H(NA,ENM2)) X = 0.75D0*S Y = X W = -0.4375D0*S*S 80 ITS = ITS + 1 C ********** LOOK FOR TWO CONSECUTIVE SMALL C SUB-DIAGONAL ELEMENTS. C FOR M=EN-2 STEP -1 UNTIL L DO -- ********** DO 90 MM = L,ENM2 M = ENM2 + L - MM ZZ = H(M,M) R = X - ZZ S = Y - ZZ P = (R*S-W)/H(M+1,M) + H(M,M+1) Q = H(M+1,M+1) - ZZ - R - S R = H(M+2,M+1) S = DABS(P) + DABS(Q) + DABS(R) P = P/S Q = Q/S R = R/S IF (M .EQ. L) GO TO 100 S1 = DABS(P)*(DABS(H(M-1,M-1))+DABS(ZZ)+DABS(H(M+1,M+1))) S2 = S1 + DABS(H(M,M-1))*(DABS(Q) + DABS(R)) IF (S1 .EQ. S2) GO TO 100 90 CONTINUE C 100 MP2 = M + 2 C DO 110 I = MP2,EN H(I,I-2) = 0.D0 IF (I .EQ. MP2) GO TO 110 H(I,I-3) = 0.D0 110 CONTINUE C ********** DOUBLE QR STEP INVOLVING ROWS L TO EN AND C COLUMNS M TO EN ********** DO 210 K = M,NA NOTLAS = K.NE.NA IF (K .EQ. M) GO TO 120 P = H(K,K-1) Q = H(K+1,K-1) R = 0.D0 IF (NOTLAS) R = H(K+2,K-1) X = DABS(P) + DABS(Q) + DABS(R) IF (X .EQ. 0.D0) GO TO 210 P = P/X Q = Q/X R = R/X 120 S = DSQRT(P*P + Q*Q + R*R) IF (P .LT. 0.D0) S = -S IF (K .EQ. M) GO TO 130 H(K,K-1) = -S*X GO TO 140 130 IF (L .NE. M) H(K,K-1) = -H(K,K-1) 140 P = P + S X = P/S Y = Q/S ZZ = R/S Q = Q/P R = R/P C ********** ROW MODIFICATION ********** DO 160 J = K,N P = H(K,J) + Q*H(K+1,J) IF (.NOT.NOTLAS) GO TO 150 P = P + R*H(K+2,J) H(K+2,J) = H(K+2,J) - P*ZZ 150 H(K+1,J) = H(K+1,J) - P*Y H(K,J) = H(K,J) - P*X 160 CONTINUE C J = MIN0(EN,K+3) C ********** COLUMN MODIFICATION ********** DO 180 I = 1,J P = X*H(I,K) + Y*H(I,K+1) IF (.NOT.NOTLAS) GO TO 170 P = P + ZZ*H(I,K+2) H(I,K+2) = H(I,K+2) - P*R 170 H(I,K+1) = H(I,K+1) - P*Q H(I,K) = H(I,K) - P 180 CONTINUE C ********** ACCUMULATE TRANSFORMATIONS ********** DO 200 I = LOW,IGH P = X*Z(I,K) + Y*Z(I,K+1) IF (.NOT.NOTLAS) GO TO 190 P = P + ZZ*Z(I,K+2) Z(I,K+2) = Z(I,K+2) - P*R 190 Z(I,K+1) = Z(I,K+1) - P*Q Z(I,K) = Z(I,K) - P 200 CONTINUE C 210 CONTINUE C GO TO 40 C ********** ONE ROOT FOUND ********** 220 H(EN,EN) = X + T WR(EN) = H(EN,EN) WI(EN) = 0.D0 EN = NA GO TO 30 C ********** TWO ROOTS FOUND ********** 230 P = (Y - X)/2.D0 Q = P*P + W ZZ = DSQRT(DABS(Q)) H(EN,EN) = X + T X = H(EN,EN) H(NA,NA) = Y + T IF (Q .LT. 0.D0) GO TO 270 C ********** REAL PAIR ********** IF (P .LT. 0.D0) ZZ = -ZZ ZZ = P + ZZ WR(NA) = X + ZZ WR(EN) = WR(NA) IF (ZZ .NE. 0.D0) WR(EN) = X - W/ZZ WI(NA) = 0.D0 WI(EN) = 0.D0 X = H(EN,NA) S = DABS(X) + DABS(ZZ) P = X/S Q = ZZ/S R = DSQRT(P*P + Q*Q) P = P/R Q = Q/R C ********** ROW MODIFICATION ********** DO 240 J = NA,N ZZ = H(NA,J) H(NA,J) = Q*ZZ + P*H(EN,J) H(EN,J) = Q*H(EN,J) - P*ZZ 240 CONTINUE C ********** COLUMN MODIFICATION ********** DO 250 I = 1,EN ZZ = H(I,NA) H(I,NA) = Q*ZZ + P*H(I,EN) H(I,EN) = Q*H(I,EN) - P*ZZ 250 CONTINUE C ********** ACCUMULATE TRANSFORMATIONS ********** DO 260 I = LOW,IGH ZZ = Z(I,NA) Z(I,NA) = Q*ZZ + P*Z(I,EN) Z(I,EN) = Q*Z(I,EN) - P*ZZ 260 CONTINUE C GO TO 280 C ********** COMPLEX PAIR ********** 270 WR(NA) = X + P WR(EN) = X + P WI(NA) = ZZ WI(EN) = -ZZ 280 EN = ENM2 GO TO 30 C ********** SET ERROR -- NO CONVERGENCE TO AN C EIGENVALUE AFTER 50 ITERATIONS ********** 290 IERR = EN RETURN 300 DO 320 I = 1,N IP1 = I + 1 IF (DABS(WI(I)) .NE. 0.D0) IP1 = IP1 + 1 IF (IP1 .GT. N) GO TO 320 DO 310 J = IP1,N H(J,I) = 0.D0 310 CONTINUE 320 CONTINUE RETURN END SUBROUTINE DSHSLV (A,B,C,M,N,NA,NB,NC,IERR) C ------------------------------------------------------------------ C DSHSLV SOLVES THE MATRIX EQUATION AX + XB = C WHERE C A IS IN LOWER SCHUR FORM AND B IN UPPER SCHUR FORM. C ------------------------------------------------------------------ INTEGER M,N,NA,NB,NC,IERR DOUBLE PRECISION A(NA,M), B(NB,N), C(NC,N) DOUBLE PRECISION SUM, P(4), T(4,4) INTEGER DK,DL,I,IB,J,JA,K,KM1,KK,L,LM1,LL C L = 1 10 LM1 = L - 1 DL = 1 IF (L .EQ. N) GO TO 15 IF (B(L+1,L) .NE. 0.D0) DL = 2 15 LL = L + DL - 1 IF (L .EQ. 1) GO TO 30 C DO 22 J = L,LL DO 21 I = 1,M SUM = C(I,J) DO 20 IB = 1,LM1 20 SUM = SUM - C(I,IB)*B(IB,J) 21 C(I,J) = SUM 22 CONTINUE C 30 K = 1 40 KM1 = K - 1 DK = 1 IF (K .EQ. M) GO TO 45 IF (A(K,K+1) .NE. 0.D0) DK = 2 45 KK = K + DK - 1 IF (K .EQ. 1) GO TO 60 C DO 52 I = K,KK DO 51 J = L,LL SUM = C(I,J) DO 50 JA = 1,KM1 50 SUM = SUM - A(I,JA)*C(JA,J) 51 C(I,J) = SUM 52 CONTINUE C 60 IF (DL .EQ. 2) GO TO 80 IF (DK .EQ. 2) GO TO 70 T(1,1) = A(K,K) + B(L,L) IF (T(1,1) .EQ. 0.D0) GO TO 200 C(K,L) = C(K,L)/T(1,1) IERR = 0 GO TO 100 C 70 T(1,1) = A(K,K) + B(L,L) T(1,2) = A(K,KK) T(2,1) = A(KK,K) T(2,2) = A(KK,KK) + B(L,L) P(1) = C(K,L) P(2) = C(KK,L) CALL DPSLV (2, 1, T, 4, P, 4, IERR) IF (IERR .NE. 0) GO TO 200 C(K,L) = P(1) C(KK,L) = P(2) GO TO 100 C 80 IF (DK .EQ. 2) GO TO 90 T(1,1) = A(K,K) + B(L,L) T(1,2) = B(LL,L) T(2,1) = B(L,LL) T(2,2) = A(K,K) + B(LL,LL) P(1) = C(K,L) P(2) = C(K,LL) CALL DPSLV (2, 1, T, 4, P, 4, IERR) IF (IERR .NE. 0) GO TO 200 C(K,L) = P(1) C(K,LL) = P(2) GO TO 100 C 90 T(1,1) = A(K,K) + B(L,L) T(1,2) = A(K,KK) T(1,3) = B(LL,L) T(1,4) = 0.D0 T(2,1) = A(KK,K) T(2,2) = A(KK,KK) + B(L,L) T(2,3) = 0.D0 T(2,4) = T(1,3) T(3,1) = B(L,LL) T(3,2) = 0.D0 T(3,3) = A(K,K) + B(LL,LL) T(3,4) = T(1,2) T(4,1) = 0.D0 T(4,2) = T(3,1) T(4,3) = T(2,1) T(4,4) = A(KK,KK) + B(LL,LL) P(1) = C(K,L) P(2) = C(KK,L) P(3) = C(K,LL) P(4) = C(KK,LL) CALL DPSLV (4, 1, T, 4, P, 4, IERR) IF (IERR .NE. 0) GO TO 200 C(K,L) = P(1) C(KK,L) = P(2) C(K,LL) = P(3) C(KK,LL) = P(4) C 100 K = K + DK IF (K .LE. M) GO TO 40 L = L + DL IF (L .LE. N) GO TO 10 RETURN C C ERROR RETURN C 200 IERR = 1 RETURN END SUBROUTINE TASLV (MO,N,A,NA,C,NC,WK,IERR) REAL A(NA,N), C(NC,N), WK(*) C ---------------------------------------------------------------------- C TASLV SOLVES THE REAL MATRIX EQUATION TRANSPOSE(A)*X + X*A = C C WHERE C IS A SYMMETRIC MATRIX. A IS REDUCED TO UPPER SCHUR FORM C AND THE TRANSFORMED SYSTEM IS SOLVED. C ---------------------------------------------------------------------- C MO IS AN INPUT ARGUMENT WHICH SPECIFIES IF THE ROUTINE IS C BEING CALLED FOR THE FIRST TIME. ON AN INITIAL CALL MO = 0 AND C WE HAVE THE FOLLOWING SETUP. C C A(NA,N) C A IS A MATRIX OF ORDER N. IT IS ASSUMED THAT C NA .GE. N .GE. 1. C C C(NC,N) C C IS A SYMMETRIC MATRIX OF ORDER N. IT IS C ASSUMED THAT NC .GE. N. C C WK(---) C WK IS AN ARRAY OF DIMENSION N**2 + 2N THAT C IS A GENERAL STORAGE AREA FOR THE ROUTINE. C C IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS. WHEN C THE ROUTINE TERMINATES, IERR HAS ONE OF THE FOLLOWING VALUES... C C IERR = 0 THE SOLUTION WAS OBTAINED AND STORED IN C. C IERR = 1 THE EQUATIONS ARE INCONSISTENT FOR A. THE C PROBLEM CANNOT BE SOLVED. C IERR = -1 A COULD NOT BE REDUCEDTO UPPER SCHUR FORM. C THE PROBLEM CANNOT BE SOLVED. C C WHEN IERR = 0, A CONTAINS THE UPPER SCHUR FORM OF THE MATRIX C A AND WK CONTAINS THE ORTHOGONAL MATRIX INVOLVED IN THE SCHUR C DECOMPOSITION OF A. THIS INFORMATION CAN BE REUSED TO SOLVE A C NEW SET OF EQUATIONS TRANSPOSE(A)*X + X*A = C WITHOUT HAVING C TO REDECOMPOSE A. IN THIS CASE, THE INPUT ARGUMENT MO MAY BE C SET TO ANY NONZERO VALUE. WHEN MO .NE. 0, IT IS ASSUMED THAT C ONLY C HAS BEEN MODIFIED. ON OUTPUT THE SOLUTION FOR THE NEW C SET OF EQUATIONS IS STORED IN C. C ---------------------------------------------------------------------- C THIS SUBROUTINE IS A MODIFICATION BY C ALFRED H. MORRIS, JR. C NAVAL SURFACE WEAPONS CENTER C DAHLGREN, VIRGINIA C OF THE SUBROUTINE ATXPXA WRITTEN BY C R.H. BARTELS AND G.W. STEWART C UNIVERSITY OF TEXAS AT AUSTIN. C C REFERENCE. BARTELS, R.H. AND STEWART, G.W., ALGORITHM 432, C SOLUTION OF THE MATRIX EQUATION AX + XB = C, COMM. ACM C 15 (1972), PP. 820-826. C ---------------------------------------------------------------------- IW = N*N + 1 CALL TASLV1 (MO,N,A,NA,WK(1),N,C,NC,WK(IW),IERR) RETURN END SUBROUTINE TASLV1 (MO,N,A,NA,U,NU,C,NC,WK,IERR) C ---------------------------------------------------------------------- C TASLV1 SOLVES THE REAL MATRIX EQUATION TRANSPOSE(A)*X + X*A = C C WHERE C IS A SYMMETRIC MATRIX. A IS REDUCED TO UPPER SCHUR FORM C AND THE TRANSFORMED SYSTEM IS SOLVED. C ---------------------------------------------------------------------- REAL A(NA,N), U(NU,N), C(NC,N), WK(*) C C IF REQUIRED, REDUCE A TO UPPER REAL SCHUR FORM C IF (MO .NE. 0) GO TO 10 CALL ORTHES (NA,N,1,N,A,WK) CALL ORTRN1 (N,1,N,A,NA,U,NU,WK) CALL SCHUR (N,1,N,A,NA,U,NU,WK(1),WK(N+1),IERR) IF (IERR .NE. 0) GO TO 200 C C TRANSFORM C C 10 DO 20 I = 1,N C(I,I) = C(I,I)/2.0 20 CONTINUE C DO 41 I = 1,N DO 31 J = 1,N WK(J) = 0.0 DO 30 K = I,N WK(J) = WK(J) + C(I,K)*U(K,J) 30 CONTINUE 31 CONTINUE DO 40 J = 1,N C(I,J) = WK(J) 40 CONTINUE 41 CONTINUE C DO 61 J = 1,N DO 51 I = 1,N WK(I) = 0.0 DO 50 K = 1,N WK(I) = WK(I) + U(K,I)*C(K,J) 50 CONTINUE 51 CONTINUE DO 60 I = 1,N C(I,J) = WK(I) 60 CONTINUE 61 CONTINUE C DO 71 I = 1,N DO 70 J = I,N C(I,J) = C(I,J) + C(J,I) C(J,I) = C(I,J) 70 CONTINUE 71 CONTINUE C C SOLVE THE TRANSFORMED SYSTEM C CALL SYMSLV (A,C,N,NA,NC,IERR) IF (IERR .NE. 0) GO TO 210 C C TRANSFORM C BACK TO THE SOLUTION C DO 80 I = 1,N C(I,I) = C(I,I)/2.0 80 CONTINUE C DO 101 I = 1,N DO 91 J = 1,N WK(J) = 0.0 DO 90 K = I,N WK(J) = WK(J) + C(I,K)*U(J,K) 90 CONTINUE 91 CONTINUE DO 100 J = 1,N C(I,J) = WK(J) 100 CONTINUE 101 CONTINUE C DO 121 J = 1,N DO 111 I = 1,N WK(I) = 0.0 DO 110 K = 1,N WK(I) = WK(I) + U(I,K)*C(K,J) 110 CONTINUE 111 CONTINUE DO 120 I = 1,N C(I,J) = WK(I) 120 CONTINUE 121 CONTINUE C DO 131 I = 1,N DO 130 J = I,N C(I,J) = C(I,J) + C(J,I) C(J,I) = C(I,J) 130 CONTINUE 131 CONTINUE RETURN C C ERROR RETURN C 200 IERR = -1 RETURN 210 IERR = 1 RETURN END SUBROUTINE SYMSLV (A,C,N,NA,NC,IERR) C ---------------------------------------------------------------------- C SYMSLV SOLVES THE MATRIX EQUATION TRANSPOSE(A)*X + X*A = C C WHERE A IS IN UPPER SCHUR FORM AND C IS SYMMETRIC. C ---------------------------------------------------------------------- INTEGER N,NA,NC,IERR REAL A(NA,N), C(NC,N), SUM, P(4), T(4,4) INTEGER DK,DL,I,IA,J,K,KK,KM1,L,LL,LDL C L = 1 10 DL = 1 IF (L .EQ. N) GO TO 20 IF (A(L+1,L) .NE. 0.0) DL = 2 20 LL = L + DL - 1 C K = L 30 KM1 = K - 1 DK = 1 IF (K .EQ. N) GO TO 35 IF (A(K+1,K) .NE. 0.0) DK = 2 35 KK = K + DK - 1 IF (K .EQ. L) GO TO 45 C DO 42 I = K,KK DO 41 J = L,LL SUM = C(I,J) DO 40 IA = L,KM1 40 SUM = SUM - A(IA,I)*C(IA,J) 41 C(I,J) = SUM 42 CONTINUE C 45 IF (DL .EQ. 2) GO TO 60 IF (DK .EQ. 2 ) GO TO 50 T(1,1) = A(K,K) + A(L,L) IF (T(1,1) .EQ. 0.0) GO TO 200 C(K,L) = C(K,L)/T(1,1) IERR = 0 GO TO 90 C 50 T(1,1) = A(K,K) + A(L,L) T(1,2) = A(KK,K) T(2,1) = A(K,KK) T(2,2) = A(KK,KK) + A(L,L) P(1) = C(K,L) P(2) = C(KK,L) CALL SLV (2, 1, T, 4, P, 4, IERR) IF (IERR .NE. 0) GO TO 200 C(K,L) = P(1) C(KK,L) = P(2) GO TO 90 C 60 IF (DK .EQ. 2) GO TO 70 T(1,1) = A(K,K) + A(L,L) T(1,2) = A(LL,L) T(2,1) = A(L,LL) T(2,2) = A(K,K) + A(LL,LL) P(1) = C(K,L) P(2) = C(K,LL) CALL SLV (2, 1, T, 4, P, 4, IERR) IF (IERR .NE. 0) GO TO 200 C(K,L) = P(1) C(K,LL) = P(2) GO TO 90 C 70 IF (K .NE. L) GO TO 80 T(1,1) = A(L,L) T(1,2) = A(LL,L) T(1,3) = 0.0 T(2,1) = A(L,LL) T(2,2) = A(L,L) + A(LL,LL) T(2,3) = T(1,2) T(3,1) = 0.0 T(3,2) = T(2,1) T(3,3) = A(LL,LL) P(1) = C(L,L)/2.0 P(2) = C(LL,L) P(3) = C(LL,LL)/2.0 CALL SLV (3, 1, T, 4, P, 4, IERR) IF (IERR .NE. 0) GO TO 200 C(L,L) = P(1) C(LL,L) = P(2) C(L,LL) = P(2) C(LL,LL) = P(3) GO TO 90 C 80 T(1,1) = A(K,K) + A(L,L) T(1,2) = A(KK,K) T(1,3) = A(LL,L) T(1,4) = 0.0 T(2,1) = A(K,KK) T(2,2) = A(KK,KK) + A(L,L) T(2,3) = 0.0 T(2,4) = T(1,3) T(3,1) = A(L,LL) T(3,2) = 0.0 T(3,3) = A(K,K) + A(LL,LL) T(3,4) = T(1,2) T(4,1) = 0.0 T(4,2) = T(3,1) T(4,3) = T(2,1) T(4,4) = A(KK,KK) + A(LL,LL) P(1) = C(K,L) P(2) = C(KK,L) P(3) = C(K,LL) P(4) = C(KK,LL) CALL SLV (4, 1, T, 4, P, 4, IERR) IF (IERR .NE. 0) GO TO 200 C(K,L) = P(1) C(KK,L) = P(2) C(K,LL) = P(3) C(KK,LL) = P(4) C 90 K = K + DK IF (K .LE. N) GO TO 30 LDL = L + DL IF (LDL .GT. N) RETURN C DO 121 J = LDL,N DO 100 I = L,LL C(I,J) = C(J,I) 100 CONTINUE DO 120 I = J,N DO 110 K = L,LL 110 C(I,J) = C(I,J) - C(I,K)*A(K,J) - A(K,I)*C(K,J) 120 C(J,I) = C(I,J) 121 CONTINUE L = LDL GO TO 10 C C ERROR RETURN C 200 IERR = 1 RETURN END SUBROUTINE DTASLV (MO,N,A,NA,C,NC,WK,IERR) DOUBLE PRECISION A(NA,N), C(NC,N), WK(*) C ---------------------------------------------------------------------- C DTASLV SOLVES THE REAL MATRIX EQUATION TRANSPOSE(A)*X + X*A = C C WHERE C IS A SYMMETRIC MATRIX. A IS REDUCED TO UPPER SCHUR FORM C AND THE TRANSFORMED SYSTEM IS SOLVED. C ---------------------------------------------------------------------- C MO IS AN INPUT ARGUMENT WHICH SPECIFIES IF THE ROUTINE IS C BEING CALLED FOR THE FIRST TIME. ON AN INITIAL CALL MO = 0 AND C WE HAVE THE FOLLOWING SETUP. C C A(NA,N) C A IS A MATRIX OF ORDER N. IT IS ASSUMED THAT C NA .GE. N .GE. 1. C C C(NC,N) C C IS A SYMMETRIC MATRIX OF ORDER N. IT IS C ASSUMED THAT NC .GE. N. C C WK(---) C WK IS AN ARRAY OF DIMENSION N**2 + 2N THAT C IS A GENERAL STORAGE AREA FOR THE ROUTINE. C C IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS. WHEN C THE ROUTINE TERMINATES, IERR HAS ONE OF THE FOLLOWING VALUES... C C IERR = 0 THE SOLUTION WAS OBTAINED AND STORED IN C. C IERR = 1 THE EQUATIONS ARE INCONSISTENT FOR A. THE C PROBLEM CANNOT BE SOLVED. C IERR = -1 A COULD NOT BE REDUCEDTO UPPER SCHUR FORM. C THE PROBLEM CANNOT BE SOLVED. C C WHEN IERR = 0, A CONTAINS THE UPPER SCHUR FORM OF THE MATRIX C A AND WK CONTAINS THE ORTHOGONAL MATRIX INVOLVED IN THE SCHUR C DECOMPOSITION OF A. THIS INFORMATION CAN BE REUSED TO SOLVE A C NEW SET OF EQUATIONS TRANSPOSE(A)*X + X*A = C WITHOUT HAVING C TO REDECOMPOSE A. IN THIS CASE, THE INPUT ARGUMENT MO MAY BE C SET TO ANY NONZERO VALUE. WHEN MO .NE. 0, IT IS ASSUMED THAT C ONLY C HAS BEEN MODIFIED. ON OUTPUT THE SOLUTION FOR THE NEW C SET OF EQUATIONS IS STORED IN C. C ---------------------------------------------------------------------- C THIS SUBROUTINE IS A MODIFICATION BY C ALFRED H. MORRIS, JR. C NAVAL SURFACE WEAPONS CENTER C DAHLGREN, VIRGINIA C OF THE SUBROUTINE ATXPXA WRITTEN BY C R.H. BARTELS AND G.W. STEWART C UNIVERSITY OF TEXAS AT AUSTIN. C C REFERENCE. BARTELS, R.H. AND STEWART, G.W., ALGORITHM 432, C SOLUTION OF THE MATRIX EQUATION AX + XB = C, COMM. ACM C 15 (1972), PP. 820-826. C ---------------------------------------------------------------------- IW = N*N + 1 CALL DTASV1 (MO,N,A,NA,WK(1),N,C,NC,WK(IW),IERR) RETURN END SUBROUTINE DTASV1 (MO,N,A,NA,U,NU,C,NC,WK,IERR) C ---------------------------------------------------------------------- C DTASV1 SOLVES THE REAL MATRIX EQUATION TRANSPOSE(A)*X + X*A = C C WHERE C IS A SYMMETRIC MATRIX. A IS REDUCED TO UPPER SCHUR FORM C AND THE TRANSFORMED SYSTEM IS SOLVED. C ---------------------------------------------------------------------- DOUBLE PRECISION A(NA,N), U(NU,N), C(NC,N), WK(*) C C IF REQUIRED, REDUCE A TO UPPER REAL SCHUR FORM C IF (MO .NE. 0) GO TO 10 CALL DORTH (NA,N,1,N,A,WK) CALL DRTRN1 (N,1,N,A,NA,U,NU,WK) CALL DSCHUR (N,1,N,A,NA,U,NU,WK(1),WK(N+1),IERR) IF (IERR .NE. 0) GO TO 200 C C TRANSFORM C C 10 DO 20 I = 1,N C(I,I) = C(I,I)/2.D0 20 CONTINUE C DO 41 I = 1,N DO 31 J = 1,N WK(J) = 0.D0 DO 30 K = I,N WK(J) = WK(J) + C(I,K)*U(K,J) 30 CONTINUE 31 CONTINUE DO 40 J = 1,N C(I,J) = WK(J) 40 CONTINUE 41 CONTINUE C DO 61 J = 1,N DO 51 I = 1,N WK(I) = 0.D0 DO 50 K = 1,N WK(I) = WK(I) + U(K,I)*C(K,J) 50 CONTINUE 51 CONTINUE DO 60 I = 1,N C(I,J) = WK(I) 60 CONTINUE 61 CONTINUE C DO 71 I = 1,N DO 70 J = I,N C(I,J) = C(I,J) + C(J,I) C(J,I) = C(I,J) 70 CONTINUE 71 CONTINUE C C SOLVE THE TRANSFORMED SYSTEM C CALL DSYMSV (A,C,N,NA,NC,IERR) IF (IERR .NE. 0) GO TO 210 C C TRANSFORM C BACK TO THE SOLUTION C DO 80 I = 1,N C(I,I) = C(I,I)/2.D0 80 CONTINUE C DO 101 I = 1,N DO 91 J = 1,N WK(J) = 0.D0 DO 90 K = I,N WK(J) = WK(J) + C(I,K)*U(J,K) 90 CONTINUE 91 CONTINUE DO 100 J = 1,N C(I,J) = WK(J) 100 CONTINUE 101 CONTINUE C DO 121 J = 1,N DO 111 I = 1,N WK(I) = 0.D0 DO 110 K = 1,N WK(I) = WK(I) + U(I,K)*C(K,J) 110 CONTINUE 111 CONTINUE DO 120 I = 1,N C(I,J) = WK(I) 120 CONTINUE 121 CONTINUE C DO 131 I = 1,N DO 130 J = I,N C(I,J) = C(I,J) + C(J,I) C(J,I) = C(I,J) 130 CONTINUE 131 CONTINUE RETURN C C ERROR RETURN C 200 IERR = -1 RETURN 210 IERR = 1 RETURN END SUBROUTINE DSYMSV (A,C,N,NA,NC,IERR) C ---------------------------------------------------------------------- C DSYMSV SOLVES THE MATRIX EQUATION TRANSPOSE(A)*X + X*A = C C WHERE A IS IN UPPER SCHUR FORM AND C IS SYMMETRIC. C ---------------------------------------------------------------------- INTEGER N,NA,NC,IERR DOUBLE PRECISION A(NA,N), C(NC,N), SUM, P(4), T(4,4) INTEGER DK,DL,I,IA,J,K,KK,KM1,L,LL,LDL C L = 1 10 DL = 1 IF (L .EQ. N) GO TO 20 IF (A(L+1,L) .NE. 0.D0) DL = 2 20 LL = L + DL - 1 C K = L 30 KM1 = K - 1 DK = 1 IF (K .EQ. N) GO TO 35 IF (A(K+1,K) .NE. 0.D0) DK = 2 35 KK = K + DK - 1 IF (K .EQ. L) GO TO 45 C DO 42 I = K,KK DO 41 J = L,LL SUM = C(I,J) DO 40 IA = L,KM1 40 SUM = SUM - A(IA,I)*C(IA,J) 41 C(I,J) = SUM 42 CONTINUE C 45 IF (DL .EQ. 2) GO TO 60 IF (DK .EQ. 2 ) GO TO 50 T(1,1) = A(K,K) + A(L,L) IF (T(1,1) .EQ. 0.D0) GO TO 200 C(K,L) = C(K,L)/T(1,1) IERR = 0 GO TO 90 C 50 T(1,1) = A(K,K) + A(L,L) T(1,2) = A(KK,K) T(2,1) = A(K,KK) T(2,2) = A(KK,KK) + A(L,L) P(1) = C(K,L) P(2) = C(KK,L) CALL DPSLV (2, 1, T, 4, P, 4, IERR) IF (IERR .NE. 0) GO TO 200 C(K,L) = P(1) C(KK,L) = P(2) GO TO 90 C 60 IF (DK .EQ. 2) GO TO 70 T(1,1) = A(K,K) + A(L,L) T(1,2) = A(LL,L) T(2,1) = A(L,LL) T(2,2) = A(K,K) + A(LL,LL) P(1) = C(K,L) P(2) = C(K,LL) CALL DPSLV (2, 1, T, 4, P, 4, IERR) IF (IERR .NE. 0) GO TO 200 C(K,L) = P(1) C(K,LL) = P(2) GO TO 90 C 70 IF (K .NE. L) GO TO 80 T(1,1) = A(L,L) T(1,2) = A(LL,L) T(1,3) = 0.D0 T(2,1) = A(L,LL) T(2,2) = A(L,L) + A(LL,LL) T(2,3) = T(1,2) T(3,1) = 0.D0 T(3,2) = T(2,1) T(3,3) = A(LL,LL) P(1) = C(L,L)/2.D0 P(2) = C(LL,L) P(3) = C(LL,LL)/2.D0 CALL DPSLV (3, 1, T, 4, P, 4, IERR) IF (IERR .NE. 0) GO TO 200 C(L,L) = P(1) C(LL,L) = P(2) C(L,LL) = P(2) C(LL,LL) = P(3) GO TO 90 C 80 T(1,1) = A(K,K) + A(L,L) T(1,2) = A(KK,K) T(1,3) = A(LL,L) T(1,4) = 0.D0 T(2,1) = A(K,KK) T(2,2) = A(KK,KK) + A(L,L) T(2,3) = 0.D0 T(2,4) = T(1,3) T(3,1) = A(L,LL) T(3,2) = 0.D0 T(3,3) = A(K,K) + A(LL,LL) T(3,4) = T(1,2) T(4,1) = 0.D0 T(4,2) = T(3,1) T(4,3) = T(2,1) T(4,4) = A(KK,KK) + A(LL,LL) P(1) = C(K,L) P(2) = C(KK,L) P(3) = C(K,LL) P(4) = C(KK,LL) CALL DPSLV (4, 1, T, 4, P, 4, IERR) IF (IERR .NE. 0) GO TO 200 C(K,L) = P(1) C(KK,L) = P(2) C(K,LL) = P(3) C(KK,LL) = P(4) C 90 K = K + DK IF (K .LE. N) GO TO 30 LDL = L + DL IF (LDL .GT. N) RETURN C DO 121 J = LDL,N DO 100 I = L,LL C(I,J) = C(J,I) 100 CONTINUE DO 120 I = J,N DO 110 K = L,LL 110 C(I,J) = C(I,J) - C(I,K)*A(K,J) - A(K,I)*C(K,J) 120 C(J,I) = C(I,J) 121 CONTINUE L = LDL GO TO 10 C C ERROR RETURN C 200 IERR = 1 RETURN END SUBROUTINE SQUINT(NM, N, A, B, C, IGUESS, S, WORK, NW, TOL, * MAXITS, IERR) C C C SUBROUTINE SQUINT BREAKS DOWN THE WORK ARRAY WORK INTO C SMALLER PIECES. THE ACTUAL SOLUTION TO AX**2 + BX + C = 0 IS C DONE IN SUBROUTINE SQUIN2. THIS SUBROUTINE MERELY RELIEVES C THE USER FROM A LONG CALLING SEQUENCE. C C C ON ENTRY, C C NM IS THE LEADING DIMENSION OF ALL THE MATRICES C IN THE CALLING PROGRAM. C C N IS THE ORDER OF THE MATRICES A, B AND C. C C A IS THE MATRIX COEFFICIENT OF X**2. C C B IS THE MATRIX COEFFICIENT OF X. C C C IS THE CONSTANT MATRIX. C C IGUESS IS AN INTEGER. IF IGUESS.NE.0, THE USER SUPPLIES AN C INITIAL GUESS AT A SOLVENT. THIS GUESS IS STORED IN C ARRAY S. IF IGUESS.EQ.0, THE SUBROUTINE PROVIDES ITS C OWN INITIAL GUESS. C C S CONTAINS THE USERS INITIAL GUESS AT A SOLVENT, IF IGUESS C HAS BEEN SET TO A NONZERO QUANTITY. OTHERWISE THE INPUT C CONTENTS IN S ARE IGNORED. C C WORK IS A WORK VECTOR. IT MUST BE DIMENSIONED AT LEAST C (7N**2 + N), WHERE N IS THE ORDER OF A, B, C AND S. C C NW IS THE DIMENSION OF THE ARRAY WORK IN THE CALLING C PROGRAM. C C TOL IS A USER-SUPPLIED ACCURACY TOLERANCE. SETTING TOL = 0.0 C CAUSES ITERATION TO PROCEED UNTIL FULL MACHINE PRECISION C IS ATTAINED. OTHERWISE, EXECUTION TERMINATES WHEN C NORM(AS**2+BS+C).LT.TOL. C C MAXITS IS AN INTEGER. IF MAXITS.NE.0, THE USER SPECIFIES THE C MOST INTERATIONS THE ALGORITHM IS TO TAKE. IF MAXITS. C .LE.0, IT IS RESET TO 30. C C C ON RETURN, C C A,B,C ARE DESTROYED. C C IGUESS CONTAINS THE NUMBER OF ITERATIONS PERFORMED TO C COMPUTE S. C C S CONTAINS THE RIGHT SOLVENT. C C WORK(1) IS A COMPLEX NUMBER WITH REAL PART EQUAL TO THE NORM C OF AS**2+BS+C. C C IERR IS AN INTEGER ERROR RETURN. C C IERR = 0 FOR A NORMAL RETURN. C C IERR = 1 INDICATES FAILURE OF SQUINT TO CONVERGE TO C A SOLVENT IN THE MAXIMUM NUMBER OF ITERATIONS. C C IERR = 2 INDICATES FAILURE IN THE UPPER REDUCTION IN C CQZIT. C C IERR = 3 INDICATES FAILURE IN THE LOWER REDUCTION IN C CQZIT. C C IERR = 10 + N INDICATES AN ERROR RETURN FROM TRISLV C ON ITERATION N, DESIGNATING INCONSISTENCY OF C THE TRIANGULAR SYSTEM. C C IERR = 999 INDICATES IMPROPER DIMENSIONING. THE C CONDITIONS NM.GE.N.GT.0 AND C NW.GE.(7*N*N + N) MUST HOLD. C INTEGER NM, N, IGUESS, NW, MAXITS, IERR, I1, I2, I3, I4, I5, I6, * I7 COMPLEX WORK(NW) COMPLEX A(NM,N), B(NM,N), C(NM,N), S(NM,N) REAL TOL I1 = N*N + 1 I2 = N*N + I1 I3 = N*N + I2 I4 = N*N + I3 I5 = N*N + I4 I6 = N*N + I5 I7 = N*N + I6 CALL SQUIN2(NM, N, A, B, C, IGUESS, S, WORK(1), WORK(I1), * WORK(I2), WORK(I3), WORK(I4), WORK(I5), WORK(I6), WORK(I7), NW, * TOL, MAXITS, IERR) RETURN END SUBROUTINE SQUIN2(NM, N, A, B, C, IGUESS, S, L, U, V, Z, R, XOLD, * EYE, TEMP, NW, TOL, MAXITS, IERR) C C SUBROUTINE SQUIN2 FINDS A RIGHT SOLVENT OF THE MATRIX C EQUATION AX**2 + BX + C = 0. C C ON ENTRY, C C NM IS THE LEADING DIMENSION OF ALL THE MATRICES IN C THE CALLING PROGRAM. C C N IS THE ORDER OF THE MATRICES A, B AND C. C C A IS THE MATRIX COEFFICIENT OF X**2. C C B IS THE MATRIX COEFFICIENT OF X. C C C IS THE CONSTANT MATRIX. C C IGUESS IS AN INTEGER SET IN THE CALL TO SQUINT. C C S IS A MATRIX SET IN THE CALL TO SQUINT. C C NW, TOL, AND MAXITS ARE INTEGER AND REAL PARAMETERS SET IN C THE CALL TO SQUINT. C C C THE FOLLOWING ARE INTERNAL VARIABLES ... C C C L IS A MATRIX CONTAINING THE ITERATE X(I) FOR C REDUCTION TO LOWER TRIANGULAR FORM. C C U IS A MATRIX CONTAINING AX(I) + B FOR REDUCTION C TO UPPER TRIANGULAR FORM. C C V IS A MATRIX CONTAINING A FOR REDUCTION TO UPPER C TRIANGULAR FORM. C C Z,R ARE MATRICES CONTAINING THE HISTORY OF THE C TRANSFORMATIONS IN THE REDUCTIONS. C C XOLD IS A MATRIX HOLDING THE CURRENT ITERATE X(I). C C EYE CONTAINS AN IDENTITY MATRIX FOR THE LOWER REDUCTION C STEP. C C TEMP IS A WORK VECTOR. C C C ON RETURN, C C A, B, C, IGUESS, S AND IERR HAVE THE SAME PROPERTIES AS C DESCRIBED IN THE RETURN FROM SUBROUTINE SQUINT. C C L(1,1) IS A COMPLEX NUMBER WITH REAL PART EQUAL TO THE NORM C OF AS**2+BS+C. C C INTEGER NM, N, IGUESS, NW, MAXITS, IERR INTEGER ITS, MATS, I, J, K COMPLEX A(NM,N), B(NM,N), C(NM,N), S(NM,N), L(NM,N), U(NM,N) COMPLEX V(NM,N), Z(NM,N), R(NM,N), XOLD(NM,N), EYE(NM,N), TEMP(N) REAL ANORM, ANI, BNORM, BNI, CNORM, CNI, XNORM, XNI REAL FXNORM, FXNI, GNORM, TNORM, T, TOL C REAL SQRT, CABS, FLOAT C COMPLEX CMPLX, CONJG K = 7*N*N + N IF (NW.LT.K) GO TO 460 IF (NM.LT.N) GO TO 460 IF (N.LE.0) GO TO 460 IF (MAXITS.LE.0) MAXITS = 30 C ********** INITIALIZE ARRAYS ********** DO 20 I=1,N DO 10 J=1,N L(I,J) = CMPLX(0.0,0.0) U(I,J) = CMPLX(0.0,0.0) V(I,J) = CMPLX(0.0,0.0) Z(I,J) = CMPLX(0.0,0.0) XOLD(I,J) = CMPLX(0.0,0.0) EYE(I,J) = CMPLX(0.0,0.0) 10 CONTINUE TEMP(I) = CMPLX(0.0,0.0) 20 CONTINUE C ********** SET INITIAL GUESS(ES) ********** ANORM = 0.0 BNORM = 0.0 CNORM = 0.0 DO 40 I=1,N ANI = 0.0 BNI = 0.0 CNI = 0.0 DO 30 J=1,N ANI = ANI + CABS(A(I,J)) BNI = BNI + CABS(B(I,J)) CNI = CNI + CABS(C(I,J)) 30 CONTINUE IF (ANI.GT.ANORM) ANORM = ANI IF (BNI.GT.BNORM) BNORM = BNI IF (CNI.GT.CNORM) CNORM = CNI 40 CONTINUE GNORM = (BNORM+SQRT(BNORM**2+4.0*ANORM*CNORM))/(2.0*ANORM) IF (IGUESS.EQ.0) GO TO 70 DO 60 I=1,N DO 50 J=1,N XOLD(I,J) = S(I,J) 50 CONTINUE 60 CONTINUE GO TO 100 C 70 DO 90 I=1,N DO 80 J=1,N XOLD(I,J) = CMPLX(0.0,0.0) 80 CONTINUE XOLD(I,I) = CMPLX(GNORM,0.0) 90 CONTINUE C 100 DO 360 ITS=1,MAXITS IF (ITS.NE.31) GO TO 130 DO 120 I=1,N DO 110 J=1,N XOLD(I,J) = CMPLX(0.0,0.0) 110 CONTINUE XOLD(I,I) = CMPLX(0.0,GNORM) 120 CONTINUE C 130 IF (ITS.NE.61) GO TO 160 DO 150 I=1,N DO 140 J=1,N XOLD(I,J) = C(I,J) 140 CONTINUE 150 CONTINUE C ********** SET UP U AND RIGHT HAND SIDE ********** 160 CALL CMPROD(N, N, N, A, NM, XOLD, NM, U, NM, U) DO 180 I=1,N DO 170 J=1,N U(I,J) = U(I,J) + B(I,J) 170 CONTINUE 180 CONTINUE CALL CMPROD(N, N, N, U, NM, XOLD, NM, S, NM, S) DO 200 I=1,N DO 190 J=1,N S(I,J) = S(I,J) + C(I,J) 190 CONTINUE 200 CONTINUE C ********** CHECK FOR CONVERGENCE ********** XNORM = 0.0 FXNORM = 0.0 DO 220 I=1,N XNI = 0.0 FXNI = 0.0 DO 210 J=1,N XNI = XNI + CABS(XOLD(I,J)) FXNI = FXNI + CABS(S(I,J)) 210 CONTINUE IF (XNI.GT.XNORM) XNORM = XNI IF (FXNI.GT.FXNORM) FXNORM = FXNI 220 CONTINUE IF (TOL.LE.0.0) GO TO 230 IF (FXNORM.LT.TOL) GO TO 370 230 TNORM = 8.0*FLOAT(N)*ANORM*XNORM**2 + 5.0*FLOAT(N)*BNORM*XNORM * + CNORM T = 1.0 + FXNORM/TNORM IF (T.EQ.1.0) GO TO 370 IF (ITS.GE.MAXITS) GO TO 400 C ********** UPPER TRIANGULARIZATION ********** IF (ITS.NE.1) GO TO 240 MATS = 1 CALL CQZHES(NM, N, U, A, MATS, Z, S, B, C) 240 DO 260 I=1,N DO 250 J=1,N V(I,J) = A(I,J) L(I,J) = CONJG(XOLD(J,I)) EYE(I,J) = CMPLX(0.0,0.0) 250 CONTINUE EYE(I,I) = CMPLX(1.0,0.0) 260 CONTINUE IF (ITS.EQ.1) GO TO 270 MATS = 2 CALL CQZHES(NM, N, U, V, MATS, Z, S, B, C) 270 CALL CQZIT(NM, N, U, V, 0.0, MATS, Z, S, IERR) IF (IERR.NE.0) GO TO 430 C ********** LOWER TRIANGULARIZATION ********** MATS = 3 CALL CQZHES(NM, N, L, EYE, MATS, R, S, B, C) CALL CQZIT(NM, N, L, EYE, 0.0, MATS, R, S, IERR) IF (IERR.NE.0) GO TO 440 CALL CTRANS(NM, N, L) C ********** UPDATE S WITH R ********** DO 310 I=1,N DO 280 J=1,N TEMP(J) = S(I,J) S(I,J) = CMPLX(0.0,0.0) 280 CONTINUE DO 300 J=1,N DO 290 K=1,N S(I,J) = S(I,J) + TEMP(K)*R(K,J) 290 CONTINUE 300 CONTINUE 310 CONTINUE DO 330 J=1,N DO 320 I=1,N L(I,J) = L(I,J)*EYE(J,J) 320 CONTINUE EYE(J,J) = CMPLX(1.0,0.0) 330 CONTINUE C ********** BACKSOLVE THE TRANSFORMED SYSTEM ********** CALL TRISLV(NM, N, U, V, L, S, TEMP, IERR) IF (IERR.NE.0) GO TO 450 C ********** TRANSLATE BACK TO THE SOLUTION ********** CALL CMPROD(N, N, N, Z, NM, S, NM, L, NM, L) CALL CTRANS(NM, N, R) CALL CMPROD(N, N, N, L, NM, R, NM, S, NM, S) DO 350 I=1,N DO 340 J=1,N XOLD(I,J) = XOLD(I,J) - S(I,J) 340 CONTINUE 350 CONTINUE 360 CONTINUE C ********** CONVERGENCE ********** 370 IGUESS = ITS - 1 L(1,1) = CMPLX(FXNORM,0.0) DO 390 I=1,N DO 380 J=1,N S(I,J) = XOLD(I,J) 380 CONTINUE 390 CONTINUE IERR = 0 RETURN C ********** ERROR RETURNS ********** 400 IERR = 1 L(1,1) = CMPLX(FXNORM,0.0) DO 420 I=1,N DO 410 J=1,N S(I,J) = XOLD(I,J) 410 CONTINUE 420 CONTINUE RETURN 430 IERR = 2 RETURN 440 IERR = 3 RETURN 450 IERR = ITS + 10 RETURN 460 IERR = 999 RETURN END SUBROUTINE CQZHES(NM, N, A, B, MATS, Z, F, G, H) C C C SUBROUTINE CQZHES IS A MODIFICATION OF THE EISPACK SUBROUTINE C QZHES. ALL OPERATIONS ARE PERFORMED IN COMPLEX ARITHMETIC, C AND THE LEFT TRANSFORMATIONS MAY ALSO BE APPLIED TO AUXILIARY C MATRICES F, G AND H. C C C ON ENTRY, C C NM IS THE LEADING DIMENSION OF THE MATRICES A AND B IN C THE MAIN PROGRAM. C C N IS THE ORDER OF THE MATRICES A AND B. C C A CONTAINS THE MATRIX TO BE REDUCED TO UPPER HESSENBERG C FORM. C C B CONTAINS THE MATRIX TO BE REDUCED TO UPPER TRAINGULAR C FORM. C C MATS IS AN INTEGER INPUT VARIABLE. C C IF MATS = 0, THE ACCUMULATION OF THE TRANSFORMATIONS C IS NOT DESIRED. C C IF MATS = ANY OTHER NUMBER BUT 0, THE TRANSFORMATIONS C ARE ACCUMULATED. C C IF MATS = 1, THE AUXILIARY MATRICES G AND H ARE UPDATED C WITH THE UNITARY MATRIX Q. C C IF MATS = 2, MATRIX B IS ASSUMED UPPER TRIANGULAR. C C IF MATS = 3, THE AUXILIARY MATRIX F IS NOT UPDATED C WITH THE UNITARY MATRIX Q. C C F, G AND H ARE AUXILIARY MATRICES. C C C ON RETURN, C C A IS UPPER HESSENBERG. C C B IS UPPER TRIANGULAR. C C Z CONTAINS THE HISTORY OF THE TRANSFORMATIONS, IF DESIRED. C C F, G AND H ARE UPDATED, IF DESIRED. C C INTEGER I, J, K, L, N, LB, L1, NM, NK1, NM1, NM2 COMPLEX A(NM,N), B(NM,N), Z(NM,N) COMPLEX RR, T, U1, U2, V1, V2, RHO COMPLEX F(NM,N), TF, G(NM,N), TG, H(NM,N), TH REAL R, S INTEGER MATS C REAL SQRT, CABS C COMPLEX CMPLX, CONJG IF (MATS.EQ.0) GO TO 30 DO 20 I=1,N DO 10 J=1,N Z(I,J) = CMPLX(0.0,0.0) 10 CONTINUE Z(I,I) = CMPLX(1.0,0.0) 20 CONTINUE C ********** REDUCE B TO UPPER TRIANGULAR FORM ********** 30 IF (N.LE.1) GO TO 260 NM1 = N - 1 IF (MATS.EQ.2) GO TO 140 DO 130 L=1,NM1 L1 = L + 1 S = 0.0 DO 40 I=L1,N S = S + CABS(B(I,L)) 40 CONTINUE IF (S.EQ.0.0) GO TO 130 S = S + CABS(B(L,L)) R = 0.0 DO 50 I=L,N B(I,L) = B(I,L)/CMPLX(S,0.0) R = R + CABS(B(I,L))**2 50 CONTINUE R = SQRT(R) RR = CMPLX(R,0.0) IF (CABS(B(L,L)).NE.0.0) RR = (B(L,L)/CABS(B(L,L)))*RR B(L,L) = B(L,L) + RR RHO = CONJG(RR)*B(L,L) DO 80 J=L1,N T = CMPLX(0.0,0.0) DO 60 I=L,N T = T + CONJG(B(I,L))*B(I,J) 60 CONTINUE T = -T/RHO DO 70 I=L,N B(I,J) = B(I,J) + T*B(I,L) 70 CONTINUE 80 CONTINUE DO 110 J=1,N T = CMPLX(0.0,0.0) TF = CMPLX(0.0,0.0) TG = CMPLX(0.0,0.0) TH = CMPLX(0.0,0.0) DO 90 I=L,N T = T + CONJG(B(I,L))*A(I,J) IF (MATS.EQ.3) GO TO 90 TF = TF + CONJG(B(I,L))*F(I,J) IF (MATS.NE.1) GO TO 90 TG = TG + CONJG(B(I,L))*G(I,J) TH = TH + CONJG(B(I,L))*H(I,J) 90 CONTINUE T = -T/RHO TF = -TF/RHO TG = -TG/RHO TH = -TH/RHO DO 100 I=L,N A(I,J) = A(I,J) + T*B(I,L) IF (MATS.EQ.3) GO TO 100 F(I,J) = F(I,J) + TF*B(I,L) IF (MATS.NE.1) GO TO 100 G(I,J) = G(I,J) + TG*B(I,L) H(I,J) = H(I,J) + TH*B(I,L) 100 CONTINUE 110 CONTINUE B(L,L) = -CMPLX(S,0.0)*RR DO 120 I=L1,N B(I,L) = CMPLX(0.0,0.0) 120 CONTINUE 130 CONTINUE C ********** REDUCE A TO UPPER HESSENBERG FORM, WHILE C KEEPING B TRIANGULAR ********** 140 IF (N.EQ.2) GO TO 260 NM2 = N - 2 DO 250 K=1,NM2 NK1 = NM1 - K DO 240 LB=1,NK1 L = N - LB L1 = L + 1 C ********** ZERO A(L+1,K) ********** S = CABS(A(L,K)) + CABS(A(L1,K)) IF (S.EQ.0.0) GO TO 240 U1 = A(L,K)/CMPLX(S,0.0) U2 = A(L1,K)/CMPLX(S,0.0) R = SQRT(CABS(U1)**2+CABS(U2)**2) RR = CMPLX(R,0.0) IF (CABS(U1).NE.0.0) RR = (U1/CABS(U1))*RR V1 = -(U1+RR)/RR V2 = -U2/RR U2 = V2/V1 DO 150 J=K,N T = A(L,J) + CONJG(U2)*A(L1,J) A(L,J) = A(L,J) + T*V1 A(L1,J) = A(L1,J) + T*V2 150 CONTINUE A(L1,K) = CMPLX(0.0,0.0) DO 160 J=L,N T = B(L,J) + CONJG(U2)*B(L1,J) B(L,J) = B(L,J) + T*V1 B(L1,J) = B(L1,J) + T*V2 160 CONTINUE IF (MATS.EQ.3) GO TO 180 DO 170 J=1,N TF = F(L,J) + CONJG(U2)*F(L1,J) F(L,J) = F(L,J) + TF*V1 F(L1,J) = F(L1,J) + TF*V2 170 CONTINUE 180 IF (MATS.NE.1) GO TO 200 DO 190 J=1,N TG = G(L,J) + CONJG(U2) + G(L1,J) TH = H(L,J) + CONJG(U2) + H(L1,J) G(L,J) = G(L,J) + TG*V1 H(L,J) = H(L,J) + TH*V1 G(L1,J) = G(L1,J) + TG*V2 H(L1,J) = H(L1,J) + TH*V2 190 CONTINUE C ********** ZERO B(L+1,L) ********** 200 S = CABS(B(L1,L1)) + CABS(B(L1,L)) IF (S.EQ.0.0) GO TO 240 U1 = B(L1,L1)/CMPLX(S,0.0) U2 = B(L1,L)/CMPLX(S,0.0) R = SQRT(CABS(U1)**2+CABS(U2)**2) RR = CMPLX(R,0.0) IF (CABS(U1).NE.0.0) RR = (U1/CABS(U1))*RR V1 = -(U1+RR)/RR V2 = -U2/RR U2 = V2/V1 DO 210 I=1,L1 T = B(I,L1) + CONJG(U2)*B(I,L) B(I,L1) = B(I,L1) + T*V1 B(I,L) = B(I,L) + T*V2 210 CONTINUE B(L1,L) = CMPLX(0.0,0.0) DO 220 I=1,N T = A(I,L1) + CONJG(U2)*A(I,L) A(I,L1) = A(I,L1) + T*V1 A(I,L) = A(I,L) + T*V2 220 CONTINUE IF (MATS.EQ.0) GO TO 240 DO 230 I=1,N T = Z(I,L1) + CONJG(U2)*Z(I,L) Z(I,L1) = Z(I,L1) + T*V1 Z(I,L) = Z(I,L) + T*V2 230 CONTINUE 240 CONTINUE 250 CONTINUE 260 RETURN END SUBROUTINE CQZIT(NM, N, A, B, EPS1, MATS, Z, F, IERR) C C C SUBROUTINE CQZIT IS A MODIFICATION OF THE EISPACK SUBROUTINE C QZIT. ALL OPERATIONS ARE PERFORMED IN COMPLEX ARITHMETIC, C AND THE LEFT TRANSFORMATIONS MAY ALSO BE APPLIED TO AN AUXILIARY C MATRIX F. C C C ON ENTRY, C C NM IS THE LEADING DIMENSION OF THE MATRICES A AND B IN C THE MAIN PROGRAM. C C N IS THE ORDER OF THE MATRICES A AND B. C C A CONTAINS AN UPPER HESSENBERG MATRIX FROM CQZHES. C C B CONTAINS AN UPPER TRIANGULAR MATRIX FROM CQZHES. C C EPS1 IS A REAL NUMBER DEFINING THE TOLERANCE USED TO DETERMINE C NEGLIGIBLE ELEMENTS OF A AND B IN THE COURSE OF THE ALG- C ORITHM. AN ELEMENT OF EITHER MATRIX WILL BE CONSIDERED C NEGLIGIBLE AND RESET TO ZERO IF IT IS NOT LARGER THAN THE C PRODUCT OF EPS1 AND THE NORM OF THE MATRIX. IF EPS1.LE.0, C RELATIVE MACHINE PRECISION WILL BE COMPUTED AND C USED INSTEAD. C C MATS IS AN INTEGER INPUT VARIABLE. IT IS SET PRIOR C TO THE CALL TO CQZHES. C C F CONTAINS AN AUXILIARY MATRIX. C C C ON RETURN, C C A IS UPPER TRIANGULAR. C C B IS UPPER TRIANGULAR. C C Z CONTAINS THE HISTORY OF THE TRANSFORMATIONS, IF DESIRED. C C F CONTAINS THE AUXILIARY MATRIX, UPDATED IF DESIRED. C C IERR IS AN INTEGER ERROR RETURN WHICH INDICATES FAILURE C OF THE QZ ALGORITHM TO REDUCE A SUBDIAGONAL ELEMENT C TO ZERO AFTER 50 ITERATIONS. C INTEGER I, J, K, L, N, EN, JJ, K1, K2, LD, LL, L1, NA, NM, ISH, * ITS, KM1, LM1 INTEGER ENM2, IERR, LOR1, ENORN COMPLEX A(NM,N), B(NM,N), Z(NM,N) COMPLEX A11, A21, A33, A34, A43, A44, B11, B22, B33, B34, B44 COMPLEX A1, A2, U1, U2, V1, V2, T, RR, SH, SS COMPLEX F(NM,N), TF REAL EPS1, EPSA, EPSB, ANORM, BNORM, ANI, BNI, SRELPR, R, S INTEGER MATS REAL SPMPAR C INTEGER MAX0, MIN0 C REAL SQRT, CABS C COMPLEX CMPLX, CONJG, CSQRT IERR = 0 C ********** COMPUTE EPSA, EPSB ********** ANORM = 0.0 BNORM = 0.0 DO 20 I=1,N ANI = 0.0 IF (I.NE.1) ANI = CABS(A(I,I-1)) BNI = 0.0 DO 10 J=I,N ANI = ANI + CABS(A(I,J)) BNI = BNI + CABS(B(I,J)) 10 CONTINUE IF (ANI.GT.ANORM) ANORM = ANI IF (BNI.GT.BNORM) BNORM = BNI 20 CONTINUE IF (ANORM.EQ.0.0) ANORM = 1.0 IF (BNORM.EQ.0.0) BNORM = 1.0 SRELPR = EPS1 IF (SRELPR.GT.0.0) GO TO 40 C C ***** WHEN EPS1 = 0 THEN SET SRELPR TO BE THE SMALLEST C NUMBER FOR WHICH 1 + SRELPR .GT. 1 ***** C SRELPR = SPMPAR(1) C 40 EPSA = SRELPR*ANORM EPSB = SRELPR*BNORM C ********** REDUCE A TO TRIANGULAR FORM, WHILE C KEEPING B TRIANGULAR ********** LOR1 = 1 ENORN = N EN = N C ********** BEGIN QZ STEP ********** 50 IF (EN.LE.1) GO TO 220 IF (MATS.EQ.0) ENORN = EN ITS = 0 NA = EN - 1 ENM2 = NA - 1 60 ISH = 1 C ********** CHECK FOR CONVERGENCE OR REDUCIBILITY ********** DO 70 LL=1,EN LM1 = EN - LL L = LM1 + 1 IF (L.EQ.1) GO TO 90 IF (CABS(A(L,LM1)).LE.EPSA) GO TO 80 70 CONTINUE 80 A(L,LM1) = CMPLX(0.0,0.0) IF (L.LT.NA) GO TO 90 C ********** 1-BY-1 BLOCK ISOLATED ********** EN = LM1 GO TO 50 C ********** CHECK FOR SMALL TOP OF B ********** 90 LD = L L1 = L + 1 B11 = B(L,L) IF (CABS(B11).GT.EPSB) GO TO 120 B(L,L) = CMPLX(0.0,0.0) S = CABS(A(L,L)) + CABS(A(L1,L)) U1 = A(L,L)/CMPLX(S,0.0) U2 = A(L1,L)/CMPLX(S,0.0) R = SQRT(CABS(U1)**2+CABS(U2)**2) RR = CMPLX(R,0.0) IF (CABS(U1).NE.0.0) RR = (U1/CABS(U1))*RR V1 = -(U1+RR)/RR V2 = -U2/RR U2 = V2/V1 DO 110 J=L,ENORN T = A(L,J) + CONJG(U2)*A(L1,J) A(L,J) = A(L,J) + T*V1 A(L1,J) = A(L1,J) + T*V2 T = B(L,J) + CONJG(U2)*B(L1,J) B(L,J) = B(L,J) + T*V1 B(L1,J) = B(L1,J) + T*V2 IF (MATS.EQ.3) GO TO 110 DO 100 JJ=1,N TF = F(L,JJ) + CONJG(U2)*F(L1,JJ) F(L,JJ) = F(L,JJ) + TF*V1 F(L1,JJ) = F(L1,JJ) + TF*V2 100 CONTINUE 110 CONTINUE IF (L.NE.1) A(L,LM1) = -A(L,LM1) LM1 = L L = L1 GO TO 80 120 A11 = A(L,L)/B11 A21 = A(L1,L)/B11 C ********** ITERATION STRATEGY ********** IF (ITS.EQ.50) GO TO 210 C ********** DETERMINE SHIFT ********** B22 = B(L1,L1) IF (CABS(B22).LT.EPSB) B22 = CMPLX(EPSB,0.0) B33 = B(NA,NA) IF (CABS(B33).LT.EPSB) B33 = CMPLX(EPSB,0.0) B44 = B(EN,EN) IF (CABS(B44).LT.EPSB) B44 = CMPLX(EPSB,0.0) A33 = A(NA,NA)/B33 A34 = A(NA,EN)/B44 A43 = A(EN,NA)/B33 A44 = A(EN,EN)/B44 B34 = B(NA,EN)/B44 T = CMPLX(0.5,0.0)*(A43*B34-A33-A44) RR = T*T + A34*A43 - A33*A44 C ********** DETERMINE SINGLE SHIFT ZEROTH COLUMN OF A ********** RR = CSQRT(RR) SH = -T + RR SS = -T - RR IF (CABS(SS-A44).LT.CABS(SH-A44)) SH = SS A1 = A11 - SH A2 = A21 IF (L.NE.LD) A(L,LM1) = -A(L,LM1) IF (ITS.NE.10) GO TO 130 A1 = CMPLX(1.0,0.0) A2 = CMPLX(1.1605,0.0) 130 ITS = ITS + 1 IF (MATS.EQ.0) LOR1 = LD C ********** MAIN LOOP ********** DO 200 K=L,NA K1 = K + 1 K2 = K + 2 KM1 = MAX0(K-1,L) LL = MIN0(EN,K1+ISH) C ********** ZERO A(K+1,K-1) ********** IF (K.EQ.L) GO TO 140 A1 = A(K,KM1) A2 = A(K1,KM1) 140 S = CABS(A1) + CABS(A2) IF (S.EQ.0.0) GO TO 60 U1 = A1/CMPLX(S,0.0) U2 = A2/CMPLX(S,0.0) R = SQRT(CABS(U1)**2+CABS(U2)**2) RR = CMPLX(R,0.0) IF (CABS(U1).NE.0.0) RR = (U1/CABS(U1))*RR V1 = -(U1+RR)/RR V2 = -U2/RR U2 = V2/V1 DO 150 J=KM1,ENORN T = A(K,J) + CONJG(U2)*A(K1,J) A(K,J) = A(K,J) + T*V1 A(K1,J) = A(K1,J) + T*V2 T = B(K,J) + CONJG(U2)*B(K1,J) B(K,J) = B(K,J) + T*V1 B(K1,J) = B(K1,J) + T*V2 150 CONTINUE IF (K.NE.L) A(K1,KM1) = CMPLX(0.0,0.0) IF (MATS.EQ.3) GO TO 170 DO 160 J=1,N TF = F(K,J) + CONJG(U2)*F(K1,J) F(K,J) = F(K,J) + TF*V1 F(K1,J) = F(K1,J) + TF*V2 160 CONTINUE C ********** ZERO B(K+1,K) ********** 170 S = CABS(B(K1,K1)) + CABS(B(K1,K)) IF (S.EQ.0.0) GO TO 200 U1 = B(K1,K1)/CMPLX(S,0.0) U2 = B(K1,K)/CMPLX(S,0.0) R = SQRT(CABS(U1)**2+CABS(U2)**2) RR = CMPLX(R,0.0) IF (CABS(U1).NE.0.0) RR = (U1/CABS(U1))*RR V1 = -(U1+RR)/RR V2 = -U2/RR U2 = V2/V1 DO 180 I=LOR1,LL T = A(I,K1) + CONJG(U2)*A(I,K) A(I,K1) = A(I,K1) + T*V1 A(I,K) = A(I,K) + T*V2 T = B(I,K1) + CONJG(U2)*B(I,K) B(I,K1) = B(I,K1) + T*V1 B(I,K) = B(I,K) + T*V2 180 CONTINUE B(K1,K) = CMPLX(0.0,0.0) IF (MATS.EQ.0) GO TO 200 DO 190 I=1,N T = Z(I,K1) + CONJG(U2)*Z(I,K) Z(I,K1) = Z(I,K1) + T*V1 Z(I,K) = Z(I,K) + T*V2 190 CONTINUE 200 CONTINUE C ********** END QZ STEP ********** GO TO 60 C ********** SET ERROR -- NEITHER BOTTOM SUBDIAGONAL ELEMENT C HAS BECOME NEGLIGIBLE AFTER 50 ITERATIONS ********** 210 IERR = EN C ********** SAVE EPSB FOR USE BY CQZVEC ********** 220 IF (N.GT.1) B(N,1) = CMPLX(EPSB,0.0) RETURN END SUBROUTINE TRISLV(NM, N, U, V, L, F, TEMP, IERR) C C C SUBROUTINE TRISLV BACKSOLVES A SYSTEM OF THE FORM C UY + VYL = F, WHERE U AND V ARE UPPER TRIANGULAR, AND C L IS LOWER TRIANGULAR. C C C ON ENTRY, C C NM IS THE LEADING DIMENSION OF THE MATRICES U, V, L AND F IN C THE MAIN PROGRAM. C C N IS THE ORDER OF THE MATRICES U, V, L AND F. C C U CONTAINS AN UPPER TRIANGULAR MATRIX. IT IS THE LEFT C COEFFICIENT OF Y IN THE FIRST TERM IN UY + VYL. C C V CONTAINS AN UPPER TRIANGULAR MATRIX. IT IS THE LEFT C COEFFICIENT OF Y IN THE SECOND TERM OF UY + VYL. C C L CONTAINS A LOWER TRIANGULAR MATRIX. IT IS THE RIGHT C COEFFICIENT OF Y IN THE SECOND TERM OF UY + VYL. C C F CONTAINS THE RIGHT HAND SIDE OF UY + VYL = F. C C TEMP CONTAINS A WORK VECTOR OF LENGTH AT LEAST N. C C ON RETURN, C C F CONTAINS THE SOLUTION Y. C C IERR IS AN ERROR RETURN DESIGNATING INCONSISTENCY OF THE C ORIGINAL SYSTEM. C IERR.EQ.0 FOR A NORMAL RETURN. C IERR.EQ.1 IF THE TRIANGULAR SYSTEM IS INCONSISTENT. C C INTEGER I, IERR, J, JP1, K, KK, KM1, M, N, NM, NM1 COMPLEX U(NM,N), V(NM,N), L(NM,N), F(NM,N) COMPLEX TEMP(N) COMPLEX DENOM, SUM REAL S, T C REAL CABS C COMPLEX CMPLX IERR = 0 NM1 = N - 1 DO 120 KK=1,N C ********** BACKSUBSTITUTE FOR ROW K. ********** K = N - KK + 1 IF (CABS(F(K,N)).NE.0.0) GO TO 10 F(K,N) = CMPLX(0.0,0.0) GO TO 30 10 DENOM = U(K,K) + V(K,K)*L(N,N) S = CABS(DENOM) T = 1.0 + S/CABS(F(K,N)) IF (T.GT.1.0) GO TO 20 IERR = 1 RETURN 20 F(K,N) = F(K,N)/DENOM IF (N.EQ.1) RETURN 30 DO 70 I=1,NM1 J = N - I JP1 = J + 1 SUM = CMPLX(0.0,0.0) DO 40 M=JP1,N SUM = SUM + F(K,M)*L(M,J) 40 CONTINUE SUM = F(K,J) - V(K,K)*SUM IF (CABS(SUM).NE.0.0) GO TO 50 F(K,J) = CMPLX(0.0,0.0) GO TO 70 50 DENOM = U(K,K) + V(K,K)*L(J,J) S = CABS(DENOM) T = 1.0 + S/CABS(SUM) IF (T.GT.1.0) GO TO 60 IERR = 1 RETURN 60 F(K,J) = SUM/DENOM 70 CONTINUE C ********** FORM TEMP = YK-TRANS*L. ********** IF (K.EQ.1) RETURN KM1 = K - 1 DO 90 I=1,N TEMP(I) = CMPLX(0.0,0.0) DO 80 J=1,N TEMP(I) = TEMP(I) + F(K,J)*L(J,I) 80 CONTINUE 90 CONTINUE C ********** PREPARE F' WHICH IS (K-1) BY N. ********** DO 110 I=1,KM1 DO 100 J=1,N F(I,J) = F(I,J) - U(I,K)*F(K,J) - V(I,K)*TEMP(J) 100 CONTINUE 110 CONTINUE 120 CONTINUE RETURN END SUBROUTINE MEXP (A, KA, N, Z, KZ, WK, IERR) REAL A(KA,N),Z(KZ,N),WK(N,*),C(8) C ---------------------------------------------------------------------- C MEXP COMPUTES EXP(A) AND STORES IT IN Z WHERE A IS A MATRIX C OF ORDER N. A IS DESTROYED BY THE ROUTINE. C C WK IS AN ARRAY OF DIMENSION (N,N+8). WK IS A WORK SPACE C FOR THE ROUTINE. C C IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS. C IERR = 0 EXP(A) WAS SUCCESSFULLY COMPUTED. C IERR = 1 THE NORM OF A IS TOO LARGE. C IERR = 2 THE PADE DENOMINATOR MATRIX IS C SINGULAR. C C WRITTEN BY ALFRED H. MORRIS C NAVAL SURFACE WEAPONS CENTER C DAHLGREN VIRGINIA C --------------- C COEFFICIENTS FOR (8,8) PADE TABLE ENTRY C --------------- DATA C(1)/.500000000000000E+00/, C(2)/.116666666666667E+00/, * C(3)/.166666666666667E-01/, C(4)/.160256410256410E-02/, * C(5)/.106837606837607E-03/, C(6)/.485625485625486E-05/, * C(7)/.138750138750139E-06/, C(8)/.192708526041859E-08/ C ---------------------------------------------------------------------- IERR = 0 IF (N .GT. 1) GO TO 10 Z(1,1) = EXP(A(1,1)) RETURN C C BALANCE A AND SELECT THE SMALLER OF THE 1-NORM C AND INFINITY-NORM OF THE RESULT C 10 CALL BALANC (KA,N,A,LOW,IGH,WK(1,N+8)) ANORM = 0.0 ANORM1 = 0.0 DO 12 J = 1,N S = 0.0 S1 = 0.0 DO 11 I = 1,N S = S + ABS(A(J,I)) 11 S1 = S1 + ABS(A(I,J)) ANORM = AMAX1(S,ANORM) 12 ANORM1 = AMAX1(S1,ANORM1) C ANORM = AMIN1(ANORM,ANORM1) S = ANORM + 0.1 IF (S .EQ. ANORM) GO TO 200 C C SELECT THE NORMALIZATION FACTOR C M = 0 IF (ANORM .LE. 1.0) GO TO 40 FACTOR = 1.0 20 M = M + 1 FACTOR = 2.0*FACTOR IF (ANORM .GT. FACTOR) GO TO 20 C C NORMALIZE THE MATRIX A C DO 31 J = 1,N DO 30 I = 1,N 30 A(I,J) = A(I,J)/FACTOR 31 CONTINUE C 40 NP1 = N + 1 NP6 = N + 6 DO 100 J = 1,N C C COMPUTE THE J-TH COLUMN OF FIRST EIGHT POWERS OF A C DO 51 I = 1,N S = 0.0 DO 50 L = 1,N 50 S = S + A(I,L)*A(L,J) 51 WK(I,NP1) = S C DO 70 K = NP1,NP6 KP1 = K + 1 DO 61 I = 1,N S = 0.0 DO 60 L = 1,N 60 S = S + A(I,L)*WK(L,K) 61 WK(I,KP1) = S 70 CONTINUE C C COMPUTE THE J-TH COLUMN OF THE NUMERATOR AND DENOMINATOR C OF THE PADE APPROXIMATION C DO 90 I = 1,N P = 0.0 Q = 0.0 K = 8 L = N + 7 DO 80 LL = 1,7 S = C(K)*WK(I,L) P = S + P Q = S - Q K = K - 1 80 L = L - 1 S = C(1)*A(I,J) Z(I,J) = P + S WK(I,J) = Q - S IF (I .NE. J) GO TO 90 Z(I,J) = Z(I,J) + 1.0 WK(I,J) = WK(I,J) + 1.0 90 CONTINUE 100 CONTINUE C C CALCULATE EXP(A) BY SOLVING WK * EXP(A) = Z C CALL SLV (N, N, WK, N, Z, KZ, IERR) IF (IERR .NE. 0) GO TO 210 IF (M .EQ. 0) GO TO 150 C C TAKE OUT THE EFFECT OF THE NORMALIZATION C OPERATION ON EXP(A) C DO 140 K = 1,M DO 121 J = 1,N DO 120 I = 1,N S = 0.0 DO 110 L = 1,N 110 S = S + Z(I,L)*Z(L,J) 120 WK(I,J) = S 121 CONTINUE C DO 131 J = 1,N DO 130 I = 1,N 130 Z(I,J) = WK(I,J) 131 CONTINUE 140 CONTINUE C C TAKE OUT THE EFFECT OF THE BALANCING C OPERATION ON EXP(A) C 150 CALL BALINV (KZ,N,Z,LOW,IGH,WK(1,N+8)) RETURN C C ERROR RETURN C 200 IERR = 1 RETURN 210 IERR = 2 RETURN END SUBROUTINE DMEXP (A, KA, N, Z, KZ, WK, IERR) DOUBLE PRECISION A(KA,N),Z(KZ,N),WK(N,*) DOUBLE PRECISION ANORM,ANORM1,C(12),FACTOR,P,Q,S,S1 C ---------------------------------------------------------------------- C DMEXP COMPUTES EXP(A) AND STORES IT IN Z WHERE A IS A MATRIX C OF ORDER N. A IS DESTROYED BY THE ROUTINE. C C WK IS AN ARRAY OF DIMENSION (N,N+12). WK IS A WORK SPACE C FOR THE ROUTINE. C C IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS. C IERR = 0 EXP(A) WAS SUCCESSFULLY COMPUTED. C IERR = 1 THE NORM OF A IS TOO LARGE. C IERR = 2 THE PADE DENOMINATOR MATRIX IS C SINGULAR. C C WRITTEN BY ALFRED H. MORRIS C NAVAL SURFACE WEAPONS CENTER C DAHLGREN VIRGINIA C --------------- C COEFFICIENTS FOR (12,12) PADE TABLE ENTRY C --------------- DATA C(1) /.500000000000000000000000000000D+00/, * C(2) /.119565217391304347826086956522D+00/, * C(3) /.181159420289855072463768115942D-01/, * C(4) /.194099378881987577639751552795D-02/, * C(5) /.155279503105590062111801242236D-03/, * C(6) /.953470633104500381388253241800D-05/, * C(7) /.454033634811666848280120591333D-06/, * C(8) /.166924130445465753044161982108D-07/, * C(9) /.463678140126293758456005505855D-09/ DATA C(10)/.927356280252587516912011011710D-11/, * C(11)/.120435880552284093105455975547D-12/, * C(12)/.772024875335154442983692150941D-15/ C ---------------------------------------------------------------------- IERR = 0 IF (N .GT. 1) GO TO 10 Z(1,1) = DEXP(A(1,1)) RETURN C C BALANCE A AND SELECT THE SMALLER OF THE 1-NORM C AND INFINITY-NORM OF THE RESULT C 10 CALL DBAL (KA,N,A,LOW,IGH,WK(1,N+12)) ANORM = 0.D0 ANORM1 = 0.D0 DO 12 J = 1,N S = 0.D0 S1 = 0.D0 DO 11 I = 1,N S = S + DABS(A(J,I)) 11 S1 = S1 + DABS(A(I,J)) ANORM = DMAX1(S,ANORM) 12 ANORM1 = DMAX1(S1,ANORM1) C ANORM = DMIN1(ANORM,ANORM1) S = ANORM + 0.1D0 IF (S .EQ. ANORM) GO TO 200 C C SELECT THE NORMALIZATION FACTOR C M = 0 IF (ANORM .LE. 1.D0) GO TO 40 FACTOR = 1.D0 20 M = M + 1 FACTOR = 2.D0*FACTOR IF (ANORM .GT. FACTOR) GO TO 20 C C NORMALIZE THE MATRIX A C DO 31 J = 1,N DO 30 I = 1,N 30 A(I,J) = A(I,J)/FACTOR 31 CONTINUE C 40 NP1 = N + 1 NP10 = N + 10 DO 100 J = 1,N C C COMPUTE THE J-TH COLUMN OF THE FIRST 12 POWERS OF A C DO 51 I = 1,N S = 0.D0 DO 50 L = 1,N 50 S = S + A(I,L)*A(L,J) 51 WK(I,NP1) = S C DO 70 K = NP1,NP10 KP1 = K + 1 DO 61 I = 1,N S = 0.D0 DO 60 L = 1,N 60 S = S + A(I,L)*WK(L,K) 61 WK(I,KP1) = S 70 CONTINUE C C COMPUTE THE J-TH COLUMN OF THE NUMERATOR AND DENOMINATOR C OF THE PADE APPROXIMATION C DO 90 I = 1,N P = 0.D0 Q = 0.D0 K = 12 L = N + 11 DO 80 LL = 1,11 S = C(K)*WK(I,L) P = S + P Q = S - Q K = K - 1 80 L = L - 1 S = C(1)*A(I,J) Z(I,J) = P + S WK(I,J) = Q - S IF (I .NE. J) GO TO 90 Z(I,J) = Z(I,J) + 1.D0 WK(I,J) = WK(I,J) + 1.D0 90 CONTINUE 100 CONTINUE C C CALCULATE EXP(A) BY SOLVING WK * EXP(A) = Z C CALL DPSLV (N, N, WK, N, Z, KZ, IERR) IF (IERR .NE. 0) GO TO 210 IF (M .EQ. 0) GO TO 150 C C TAKE OUT THE EFFECT OF THE NORMALIZATION C OPERATION ON EXP(A) C DO 140 K = 1,M DO 121 J = 1,N DO 120 I = 1,N S = 0.D0 DO 110 L = 1,N 110 S = S + Z(I,L)*Z(L,J) 120 WK(I,J) = S 121 CONTINUE C DO 131 J = 1,N DO 130 I = 1,N 130 Z(I,J) = WK(I,J) 131 CONTINUE 140 CONTINUE C C TAKE OUT THE EFFECT OF THE BALANCING C OPERATION ON EXP(A) C 150 CALL DBALNV (KZ,N,Z,LOW,IGH,WK(1,N+12)) RETURN C C ERROR RETURN C 200 IERR = 1 RETURN 210 IERR = 2 RETURN END SUBROUTINE LE (ROWK,N,B,C,D,IP,IERR) C ****************************************************************** C SOLUTION OF LINEAR EQUATIONS WITH REDUCED STORAGE C ****************************************************************** REAL B(N),C(N),D(*) INTEGER IP(*) EXTERNAL ROWK DATA ZERO/0.0/ C C SET THE NECESSARY CONSTANTS C IERR = 0 NP1 = N + 1 MAX = N*N/4 + N + 3 K = 1 IFLAG = -1 C C GET THE FIRST COLUMN OF THE TRANSPOSED SYSTEM C CALL ROWK(N,1,C) BK = B(1) C IF (N .GT. 1) GO TO 10 IF (C(1) .EQ. ZERO) GO TO 200 C(1) = BK/C(1) RETURN C C FIND THE PIVOT FOR COLUMN 1 C 10 M = 1 DO 20 I = 2,N IF (ABS(C(M)) .LT. ABS(C(I))) M = I 20 CONTINUE C IP(1) = M C1 = C(M) C(M) = C(1) C(1) = C1 IF (C(1) .EQ. ZERO) GO TO 200 C C FIND THE FIRST ELEMENTARY MATRIX AND STORE IT IN D C DO 30 I = 2,N 30 D(I-1) = -C(I)/C(1) D(N) = BK/C(1) C C K LOOP - EACH K FOR A NEW COLUMN OF THE TRANSPOSED SYSTEM C DO 120 K = 2,N KP1 = K + 1 KM1 = K - 1 C C GET COLUMN K C CALL ROWK(N,K,C) DO 40 J = 1,KM1 M = IP(J) CJ = C(J) C(J) = C(M) 40 C(M) = CJ BK = B(K) C IFLAG = -IFLAG LCOL = NP1 - K LCOLP1 = LCOL + 1 LASTM1 = 1 LAST = MAX - N + K IF (K .EQ. 2) GO TO 50 C LASTM1 = MAX - N + KM1 IF (IFLAG .LT. 0) LAST = LAST - N + K - 2 IF (IFLAG .GT. 0) LASTM1 = LASTM1 - N + K - 3 C C J LOOP - EFFECT OF COLUMNS 1 TO K-1 OF L-INVERSE C 50 DO 61 J = 1,KM1 CJ = C(J) IJ = (J-1)*LCOLP1 IF (J .EQ. KM1) IJ = LASTM1 - 1 C C I LOOP - EFFECT OF L-INVERSE ON ROWS K TO N+1 C DO 60 I = K,N IJ = IJ + 1 60 C(I) = C(I) + D(IJ)*CJ 61 BK = BK - D(IJ+1)*CJ C C K=N CASE C M = K IF (K .LT. N) GO TO 70 IF (C(K) .EQ. ZERO) GO TO 200 D(LAST) = BK/C(K) GO TO 90 C C FIND THE PIVOT C 70 DO 71 I = KP1,N IF (ABS(C(M)) .LT. ABS(C(I))) M = I 71 CONTINUE C IP(K) = M CK = C(M) C(M) = C(K) C(K) = CK IF (C(K) .EQ. ZERO) GO TO 200 C C FIND THE K-TH ELEMENTARY MATRIX C IK = LAST DO 80 I = KP1,N D(IK) = -C(I)/C(K) 80 IK = IK + 1 D(IK) = BK/C(K) C C FORM THE PRODUCT OF THE ELEMENTARY MATRICES C 90 DO 110 J = 1,KM1 KJOLD = J*LCOLP1 + K - NP1 MJOLD = KJOLD + M - K IJ = (J-1)*LCOL IJOLD = IJ + J IF (J .NE. KM1) GO TO 100 C KJOLD = LASTM1 MJOLD = LASTM1 + M - K IJOLD = LASTM1 C 100 IK = LAST - 1 DKJ = D(MJOLD) D(MJOLD) = D(KJOLD) DO 110 I = KP1,NP1 IJ = IJ + 1 IJOLD = IJOLD + 1 IK = IK + 1 D(IJ) = D(IJOLD) + D(IK)*DKJ 110 CONTINUE 120 CONTINUE C LAST = MAX IF (IFLAG .LT. 0) LAST = MAX - 2 D(N) = D(LAST) C C INSERT THE SOLUTION IN C C DO 130 I = 1,N 130 C(I) = D(I) C NM1 = N - 1 DO 140 I = 1,NM1 K = N - I M = IP(K) CK = C(K) C(K) = C(M) 140 C(M) = CK RETURN C C THE SYSTEM IS SINGULAR C 200 IERR = K RETURN END SUBROUTINE DPLE (ROWK,N,B,C,D,IP,IERR) C ****************************************************************** C SOLUTION OF LINEAR EQUATIONS WITH REDUCED STORAGE C ****************************************************************** DOUBLE PRECISION B(N),C(N),D(*) INTEGER IP(*) DOUBLE PRECISION BK,CJ,CK,C1,DKJ,ZERO EXTERNAL ROWK DATA ZERO/0.D0/ C C SET THE NECESSARY CONSTANTS C IERR = 0 NP1 = N + 1 MAX = N*N/4 + N + 3 K = 1 IFLAG = -1 C C GET THE FIRST COLUMN OF THE TRANSPOSED SYSTEM C CALL ROWK(N,1,C) BK = B(1) C IF (N .GT. 1) GO TO 10 IF (C(1) .EQ. ZERO) GO TO 200 C(1) = BK/C(1) RETURN C C FIND THE PIVOT FOR COLUMN 1 C 10 M = 1 DO 20 I = 2,N IF (DABS(C(M)) .LT. DABS(C(I))) M = I 20 CONTINUE C IP(1) = M C1 = C(M) C(M) = C(1) C(1) = C1 IF (C(1) .EQ. ZERO) GO TO 200 C C FIND THE FIRST ELEMENTARY MATRIX AND STORE IT IN D C DO 30 I = 2,N 30 D(I-1) = -C(I)/C(1) D(N) = BK/C(1) C C K LOOP - EACH K FOR A NEW COLUMN OF THE TRANSPOSED SYSTEM C DO 120 K = 2,N KP1 = K + 1 KM1 = K - 1 C C GET COLUMN K C CALL ROWK(N,K,C) DO 40 J = 1,KM1 M = IP(J) CJ = C(J) C(J) = C(M) 40 C(M) = CJ BK = B(K) C IFLAG = -IFLAG LCOL = NP1 - K LCOLP1 = LCOL + 1 LASTM1 = 1 LAST = MAX - N + K IF (K .EQ. 2) GO TO 50 C LASTM1 = MAX - N + KM1 IF (IFLAG .LT. 0) LAST = LAST - N + K - 2 IF (IFLAG .GT. 0) LASTM1 = LASTM1 - N + K - 3 C C J LOOP - EFFECT OF COLUMNS 1 TO K-1 OF L-INVERSE C 50 DO 61 J = 1,KM1 CJ = C(J) IJ = (J-1)*LCOLP1 IF (J .EQ. KM1) IJ = LASTM1 - 1 C C I LOOP - EFFECT OF L-INVERSE ON ROWS K TO N+1 C DO 60 I = K,N IJ = IJ + 1 60 C(I) = C(I) + D(IJ)*CJ 61 BK = BK - D(IJ+1)*CJ C C K=N CASE C M = K IF (K .LT. N) GO TO 70 IF (C(K) .EQ. ZERO) GO TO 200 D(LAST) = BK/C(K) GO TO 90 C C FIND THE PIVOT C 70 DO 71 I = KP1,N IF (DABS(C(M)) .LT. DABS(C(I))) M = I 71 CONTINUE C IP(K) = M CK = C(M) C(M) = C(K) C(K) = CK IF (C(K) .EQ. ZERO) GO TO 200 C C FIND THE K-TH ELEMENTARY MATRIX C IK = LAST DO 80 I = KP1,N D(IK) = -C(I)/C(K) 80 IK = IK + 1 D(IK) = BK/C(K) C C FORM THE PRODUCT OF THE ELEMENTARY MATRICES C 90 DO 110 J = 1,KM1 KJOLD = J*LCOLP1 + K - NP1 MJOLD = KJOLD + M - K IJ = (J-1)*LCOL IJOLD = IJ + J IF (J .NE. KM1) GO TO 100 C KJOLD = LASTM1 MJOLD = LASTM1 + M - K IJOLD = LASTM1 C 100 IK = LAST - 1 DKJ = D(MJOLD) D(MJOLD) = D(KJOLD) DO 110 I = KP1,NP1 IJ = IJ + 1 IJOLD = IJOLD + 1 IK = IK + 1 D(IJ) = D(IJOLD) + D(IK)*DKJ 110 CONTINUE 120 CONTINUE C LAST = MAX IF (IFLAG .LT. 0) LAST = MAX - 2 D(N) = D(LAST) C C INSERT THE SOLUTION IN C C DO 130 I = 1,N 130 C(I) = D(I) C NM1 = N - 1 DO 140 I = 1,NM1 K = N - I M = IP(K) CK = C(K) C(K) = C(M) 140 C(M) = CK RETURN C C THE SYSTEM IS SINGULAR C 200 IERR = K RETURN END SUBROUTINE CLE (ROWK,N,B,C,D,IP,IERR) C ****************************************************************** C SOLUTION OF COMPLEX LINEAR EQUATIONS WITH REDUCED STORAGE C ****************************************************************** COMPLEX B(N),C(N),D(*) INTEGER IP(*) COMPLEX BK,CJ,CK,C1,DKJ,ZERO EXTERNAL ROWK DATA ZERO/(0.0,0.0)/ C C SET THE NECESSARY CONSTANTS C IERR = 0 NP1 = N + 1 MAX = N*N/4 + N + 3 K = 1 IFLAG = -1 C C GET THE FIRST COLUMN OF THE TRANSPOSED SYSTEM C CALL ROWK(N,1,C) BK = B(1) C IF (N .GT. 1) GO TO 10 IF (C(1) .EQ. ZERO) GO TO 200 C(1) = BK/C(1) RETURN C C FIND THE PIVOT FOR COLUMN 1 C 10 M = 1 S = ABS(REAL(C(1))) + ABS(AIMAG(C(1))) DO 20 I = 2,N SI = ABS(REAL(C(I))) + ABS(AIMAG(C(I))) IF (SI .LE. S) GO TO 20 M = I S = SI 20 CONTINUE C IP(1) = M C1 = C(M) C(M) = C(1) C(1) = C1 IF (C(1) .EQ. ZERO) GO TO 200 C C FIND THE FIRST ELEMENTARY MATRIX AND STORE IT IN D C DO 30 I = 2,N 30 D(I-1) = -C(I)/C(1) D(N) = BK/C(1) C C K LOOP - EACH K FOR A NEW COLUMN OF THE TRANSPOSED SYSTEM C DO 120 K = 2,N KP1 = K + 1 KM1 = K - 1 C C GET COLUMN K C CALL ROWK(N,K,C) DO 40 J = 1,KM1 M = IP(J) CJ = C(J) C(J) = C(M) 40 C(M) = CJ BK = B(K) C IFLAG = -IFLAG LCOL = NP1 - K LCOLP1 = LCOL + 1 LASTM1 = 1 LAST = MAX - N + K IF (K .EQ. 2) GO TO 50 C LASTM1 = MAX - N + KM1 IF (IFLAG .LT. 0) LAST = LAST - N + K - 2 IF (IFLAG .GT. 0) LASTM1 = LASTM1 - N + K - 3 C C J LOOP - EFFECT OF COLUMNS 1 TO K-1 OF L-INVERSE C 50 DO 61 J = 1,KM1 CJ = C(J) IJ = (J-1)*LCOLP1 IF (J .EQ. KM1) IJ = LASTM1 - 1 C C I LOOP - EFFECT OF L-INVERSE ON ROWS K TO N+1 C DO 60 I = K,N IJ = IJ + 1 60 C(I) = C(I) + D(IJ)*CJ 61 BK = BK - D(IJ+1)*CJ C C K=N CASE C M = K IF (K .LT. N) GO TO 70 IF (C(K) .EQ. ZERO) GO TO 200 D(LAST) = BK/C(K) GO TO 90 C C FIND THE PIVOT C 70 S = ABS(REAL(C(K))) + ABS(AIMAG(C(K))) DO 71 I = KP1,N SI = ABS(REAL(C(I))) + ABS(AIMAG(C(I))) IF (SI .LE. S) GO TO 71 M = I S = SI 71 CONTINUE C IP(K) = M CK = C(M) C(M) = C(K) C(K) = CK IF (C(K) .EQ. ZERO) GO TO 200 C C FIND THE K-TH ELEMENTARY MATRIX C IK = LAST DO 80 I = KP1,N D(IK) = -C(I)/C(K) 80 IK = IK + 1 D(IK) = BK/C(K) C C FORM THE PRODUCT OF THE ELEMENTARY MATRICES C 90 DO 110 J = 1,KM1 KJOLD = J*LCOLP1 + K - NP1 MJOLD = KJOLD + M - K IJ = (J-1)*LCOL IJOLD = IJ + J IF (J .NE. KM1) GO TO 100 C KJOLD = LASTM1 MJOLD = LASTM1 + M - K IJOLD = LASTM1 C 100 IK = LAST - 1 DKJ = D(MJOLD) D(MJOLD) = D(KJOLD) DO 110 I = KP1,NP1 IJ = IJ + 1 IJOLD = IJOLD + 1 IK = IK + 1 D(IJ) = D(IJOLD) + D(IK)*DKJ 110 CONTINUE 120 CONTINUE C LAST = MAX IF (IFLAG .LT. 0) LAST = MAX - 2 D(N) = D(LAST) C C INSERT THE SOLUTION IN C C DO 130 I = 1,N 130 C(I) = D(I) C NM1 = N - 1 DO 140 I = 1,NM1 K = N - I M = IP(K) CK = C(K) C(K) = C(M) 140 C(M) = CK RETURN C C THE SYSTEM IS SINGULAR C 200 IERR = K RETURN END SUBROUTINE CVBR (B,KB,M,N,ML,MU,A,KA) C----------------------------------------------------------------------- C CONVERSION OF REAL MATRICES FROM BANDED TO C STANDARD FORM C----------------------------------------------------------------------- REAL A(KA,N), B(KB,*) C C STORE THE NONZERO DATA OF THE FIRST ML ROWS C IF (ML .EQ. 0) GO TO 20 DO 11 I = 1,ML JMAX = MIN0(N,I + MU) K = ML + 1 - I DO 10 J = 1,JMAX K = K + 1 10 A(I,J) = B(I,K) 11 CONTINUE C C STORE THE REMAINING NONZERO DATA C 20 IMIN = ML + 1 IMAX = MIN0(M,ML + N) L = 0 DO 22 I = IMIN,IMAX JMIN = I - ML JMAX = MIN0(N,I + MU) J = JMAX DO 21 JJ = JMIN,JMAX K = J - L A(I,J) = B(I,K) 21 J = J - 1 L = L + 1 22 CONTINUE C C INSERT ZEROS IN THE UPPER RIGHT CORNER C JMIN = MU + 2 IF (JMIN .GT. N) GO TO 40 IMAX0 = 1 DO 31 J = JMIN,N DO 30 I = 1,IMAX0 30 A(I,J) = 0.0 IMAX0 = MIN0(IMAX,IMAX0 + 1) 31 CONTINUE C C INSERT ZEROS IN THE LOWER LEFT CORNER C 40 IF (IMIN .EQ. IMAX) GO TO 50 JMAX = IMAX - IMIN DO 42 J = 1,JMAX IMIN = IMIN + 1 DO 41 I = IMIN,IMAX 41 A(I,J) = 0.0 42 CONTINUE C C STORE ZEROS IN THE FINAL M-IMAX ROWS C 50 IF (IMAX .EQ. M) RETURN IMIN = IMAX + 1 DO 52 J = 1,N DO 51 I = IMIN,M 51 A(I,J) = 0.0 52 CONTINUE RETURN END SUBROUTINE CVRB (A,KA,M,N,ML,MU,B,KB) C----------------------------------------------------------------------- C CONVERSION OF REAL MATRICES FROM STANDARD TO BANDED C FORM WHEN ML AND MU ARE GIVEN C----------------------------------------------------------------------- REAL A(KA,N), B(KB,*) C C STORE THE NONZERO DATA OF THE FIRST ML ROWS C IF (ML .EQ. 0) GO TO 30 L = ML DO 11 I = 1,ML JMAX = MIN0(N,I + MU) J = JMAX DO 10 JJ = 1,JMAX K = J + L B(I,K) = A(I,J) 10 J = J - 1 L = L - 1 11 CONTINUE C C INSERT ZEROS IN THE UPPER LEFT CORNER C IMAX = ML DO 21 J = 1,ML DO 20 I = 1,IMAX 20 B(I,J) = 0.0 IMAX = IMAX - 1 21 CONTINUE C C STORE THE REMAINING NONZERO DATA C 30 IMIN = ML + 1 IMAX = MIN0(M,ML + N) DO 32 I = IMIN,IMAX JMIN = I - ML JMAX = MIN0(N,I + MU) K = 0 DO 31 J = JMIN,JMAX K = K + 1 31 B(I,K) = A(I,J) 32 CONTINUE C C INSERT ZEROS IN THE LOWER RIGHT CORNER C JMAX = ML + MU + 1 IF (K .EQ. JMAX) GO TO 50 JMIN = K + 1 IMIN = IMAX DO 41 J = JMIN,JMAX DO 40 I = IMIN,IMAX 40 B(I,J) = 0.0 IMIN = IMIN - 1 41 CONTINUE C C STORE ZEROS IN THE FINAL M-IMAX ROWS C 50 IF (IMAX .EQ. M) RETURN IMIN = IMAX + 1 DO 52 J = 1,JMAX DO 51 I = IMIN,M 51 B(I,J) = 0.0 52 CONTINUE RETURN END SUBROUTINE CVRB1 (A,KA,M,N,ML,MU,B,KB,NB,IERR) C----------------------------------------------------------------------- C CONVERSION OF REAL MATRICES FROM STANDARD C TO BANDED FORM C----------------------------------------------------------------------- REAL A(KA,N), B(KB,NB) C C COMPUTATION OF ML AND MU C NM1 = N - 1 IMIN = M IF (M .EQ. 1) GO TO 20 DO 11 L = 2,M J = 1 IMAX = MIN0(M,IMIN + NM1) DO 10 I = IMIN,IMAX IF (A(I,J) .NE. 0.0) GO TO 20 10 J = J + 1 IMIN = IMIN - 1 11 CONTINUE C 20 MM1 = M - 1 JMIN = N IF (N .EQ. 1) GO TO 30 DO 22 L = 2,N I = 1 JMAX = MIN0(N,JMIN + MM1) DO 21 J = JMIN,JMAX IF (A(I,J) .NE. 0.0) GO TO 30 21 I = I + 1 JMIN = JMIN - 1 22 CONTINUE C 30 ML = IMIN - 1 MU = JMIN - 1 KMAX = ML + MU + 1 IF (KMAX .GT. NB) GO TO 40 C C STORE THE MATRIX IN B C IERR = 0 CALL CVRB (A,KA,M,N,ML,MU,B,KB) RETURN C C ERROR RETURN C 40 IERR = KMAX RETURN END SUBROUTINE CVBD (B,KB,M,N,ML,MU,A,KA) C----------------------------------------------------------------------- C CONVERSION OF DOUBLE PRECISION MATRICES FROM BANDED C TO STANDARD FORM C----------------------------------------------------------------------- DOUBLE PRECISION A(KA,N), B(KB,*) C C STORE THE NONZERO DATA OF THE FIRST ML ROWS C IF (ML .EQ. 0) GO TO 20 DO 11 I = 1,ML JMAX = MIN0(N,I + MU) K = ML + 1 - I DO 10 J = 1,JMAX K = K + 1 10 A(I,J) = B(I,K) 11 CONTINUE C C STORE THE REMAINING NONZERO DATA C 20 IMIN = ML + 1 IMAX = MIN0(M,ML + N) L = 0 DO 22 I = IMIN,IMAX JMIN = I - ML JMAX = MIN0(N,I + MU) J = JMAX DO 21 JJ = JMIN,JMAX K = J - L A(I,J) = B(I,K) 21 J = J - 1 L = L + 1 22 CONTINUE C C INSERT ZEROS IN THE UPPER RIGHT CORNER C JMIN = MU + 2 IF (JMIN .GT. N) GO TO 40 IMAX0 = 1 DO 31 J = JMIN,N DO 30 I = 1,IMAX0 30 A(I,J) = 0.D0 IMAX0 = MIN0(IMAX,IMAX0 + 1) 31 CONTINUE C C INSERT ZEROS IN THE LOWER LEFT CORNER C 40 IF (IMIN .EQ. IMAX) GO TO 50 JMAX = IMAX - IMIN DO 42 J = 1,JMAX IMIN = IMIN + 1 DO 41 I = IMIN,IMAX 41 A(I,J) = 0.D0 42 CONTINUE C C STORE ZEROS IN THE FINAL M-IMAX ROWS C 50 IF (IMAX .EQ. M) RETURN IMIN = IMAX + 1 DO 52 J = 1,N DO 51 I = IMIN,M 51 A(I,J) = 0.D0 52 CONTINUE RETURN END SUBROUTINE CVDB (A,KA,M,N,ML,MU,B,KB) C----------------------------------------------------------------------- C CONVERSION OF DOUBLE PRECISION MATRICES FROM STANDARD C TO BANDED FORM WHEN ML AND MU ARE GIVEN C----------------------------------------------------------------------- DOUBLE PRECISION A(KA,N), B(KB,*) C C STORE THE NONZERO DATA OF THE FIRST ML ROWS C IF (ML .EQ. 0) GO TO 30 L = ML DO 11 I = 1,ML JMAX = MIN0(N,I + MU) J = JMAX DO 10 JJ = 1,JMAX K = J + L B(I,K) = A(I,J) 10 J = J - 1 L = L - 1 11 CONTINUE C C INSERT ZEROS IN THE UPPER LEFT CORNER C IMAX = ML DO 21 J = 1,ML DO 20 I = 1,IMAX 20 B(I,J) = 0.D0 IMAX = IMAX - 1 21 CONTINUE C C STORE THE REMAINING NONZERO DATA C 30 IMIN = ML + 1 IMAX = MIN0(M,ML + N) DO 32 I = IMIN,IMAX JMIN = I - ML JMAX = MIN0(N,I + MU) K = 0 DO 31 J = JMIN,JMAX K = K + 1 31 B(I,K) = A(I,J) 32 CONTINUE C C INSERT ZEROS IN THE LOWER RIGHT CORNER C JMAX = ML + MU + 1 IF (K .EQ. JMAX) GO TO 50 JMIN = K + 1 IMIN = IMAX DO 41 J = JMIN,JMAX DO 40 I = IMIN,IMAX 40 B(I,J) = 0.D0 IMIN = IMIN - 1 41 CONTINUE C C STORE ZEROS IN THE FINAL M-IMAX ROWS C 50 IF (IMAX .EQ. M) RETURN IMIN = IMAX + 1 DO 52 J = 1,JMAX DO 51 I = IMIN,M 51 B(I,J) = 0.D0 52 CONTINUE RETURN END SUBROUTINE CVDB1 (A,KA,M,N,ML,MU,B,KB,NB,IERR) C----------------------------------------------------------------------- C CONVERSION OF DOUBLE PRECISION MATRICES FROM STANDARD C TO BANDED FORM C----------------------------------------------------------------------- DOUBLE PRECISION A(KA,N), B(KB,NB) C C COMPUTATION OF ML AND MU C NM1 = N - 1 IMIN = M IF (M .EQ. 1) GO TO 20 DO 11 L = 2,M J = 1 IMAX = MIN0(M,IMIN + NM1) DO 10 I = IMIN,IMAX IF (A(I,J) .NE. 0.D0) GO TO 20 10 J = J + 1 IMIN = IMIN - 1 11 CONTINUE C 20 MM1 = M - 1 JMIN = N IF (N .EQ. 1) GO TO 30 DO 22 L = 2,N I = 1 JMAX = MIN0(N,JMIN + MM1) DO 21 J = JMIN,JMAX IF (A(I,J) .NE. 0.D0) GO TO 30 21 I = I + 1 JMIN = JMIN - 1 22 CONTINUE C 30 ML = IMIN - 1 MU = JMIN - 1 KMAX = ML + MU + 1 IF (KMAX .GT. NB) GO TO 40 C C STORE THE MATRIX IN B C IERR = 0 CALL CVDB (A,KA,M,N,ML,MU,B,KB) RETURN C C ERROR RETURN C 40 IERR = KMAX RETURN END SUBROUTINE CVBC (B,KB,M,N,ML,MU,A,KA) C----------------------------------------------------------------------- C CONVERSION OF COMPLEX MATRICES FROM BANDED TO C STANDARD FORM C----------------------------------------------------------------------- COMPLEX A(KA,N), B(KB,*) C C STORE THE NONZERO DATA OF THE FIRST ML ROWS C IF (ML .EQ. 0) GO TO 20 DO 11 I = 1,ML JMAX = MIN0(N,I + MU) K = ML + 1 - I DO 10 J = 1,JMAX K = K + 1 10 A(I,J) = B(I,K) 11 CONTINUE C C STORE THE REMAINING NONZERO DATA C 20 IMIN = ML + 1 IMAX = MIN0(M,ML + N) L = 0 DO 22 I = IMIN,IMAX JMIN = I - ML JMAX = MIN0(N,I + MU) J = JMAX DO 21 JJ = JMIN,JMAX K = J - L A(I,J) = B(I,K) 21 J = J - 1 L = L + 1 22 CONTINUE C C INSERT ZEROS IN THE UPPER RIGHT CORNER C JMIN = MU + 2 IF (JMIN .GT. N) GO TO 40 IMAX0 = 1 DO 31 J = JMIN,N DO 30 I = 1,IMAX0 30 A(I,J) = (0.0,0.0) IMAX0 = MIN0(IMAX,IMAX0 + 1) 31 CONTINUE C C INSERT ZEROS IN THE LOWER LEFT CORNER C 40 IF (IMIN .EQ. IMAX) GO TO 50 JMAX = IMAX - IMIN DO 42 J = 1,JMAX IMIN = IMIN + 1 DO 41 I = IMIN,IMAX 41 A(I,J) = (0.0,0.0) 42 CONTINUE C C STORE ZEROS IN THE FINAL M-IMAX ROWS C 50 IF (IMAX .EQ. M) RETURN IMIN = IMAX + 1 DO 52 J = 1,N DO 51 I = IMIN,M 51 A(I,J) = (0.0,0.0) 52 CONTINUE RETURN END SUBROUTINE CVCB (A,KA,M,N,ML,MU,B,KB) C----------------------------------------------------------------------- C CONVERSION OF COMPLEX MATRICES FROM STANDARD TO BANDED C FORM WHEN ML AND MU ARE GIVEN C----------------------------------------------------------------------- COMPLEX A(KA,N), B(KB,*) C C STORE THE NONZERO DATA OF THE FIRST ML ROWS C IF (ML .EQ. 0) GO TO 30 L = ML DO 11 I = 1,ML JMAX = MIN0(N,I + MU) J = JMAX DO 10 JJ = 1,JMAX K = J + L B(I,K) = A(I,J) 10 J = J - 1 L = L - 1 11 CONTINUE C C INSERT ZEROS IN THE UPPER LEFT CORNER C IMAX = ML DO 21 J = 1,ML DO 20 I = 1,IMAX 20 B(I,J) = (0.0,0.0) IMAX = IMAX - 1 21 CONTINUE C C STORE THE REMAINING NONZERO DATA C 30 IMIN = ML + 1 IMAX = MIN0(M,ML + N) DO 32 I = IMIN,IMAX JMIN = I - ML JMAX = MIN0(N,I + MU) K = 0 DO 31 J = JMIN,JMAX K = K + 1 31 B(I,K) = A(I,J) 32 CONTINUE C C INSERT ZEROS IN THE LOWER RIGHT CORNER C JMAX = ML + MU + 1 IF (K .EQ. JMAX) GO TO 50 JMIN = K + 1 IMIN = IMAX DO 41 J = JMIN,JMAX DO 40 I = IMIN,IMAX 40 B(I,J) = (0.0,0.0) IMIN = IMIN - 1 41 CONTINUE C C STORE ZEROS IN THE FINAL M-IMAX ROWS C 50 IF (IMAX .EQ. M) RETURN IMIN = IMAX + 1 DO 52 J = 1,JMAX DO 51 I = IMIN,M 51 B(I,J) = (0.0,0.0) 52 CONTINUE RETURN END SUBROUTINE CVCB1 (A,KA,M,N,ML,MU,B,KB,NB,IERR) C----------------------------------------------------------------------- C CONVERSION OF COMPLEX MATRICES FROM STANDARD C TO BANDED FORM C----------------------------------------------------------------------- COMPLEX A(KA,N), B(KB,NB) C C COMPUTATION OF ML AND MU C NM1 = N - 1 IMIN = M IF (M .EQ. 1) GO TO 20 DO 11 L = 2,M J = 1 IMAX = MIN0(M,IMIN + NM1) DO 10 I = IMIN,IMAX IF (A(I,J) .NE. (0.0,0.0)) GO TO 20 10 J = J + 1 IMIN = IMIN - 1 11 CONTINUE C 20 MM1 = M - 1 JMIN = N IF (N .EQ. 1) GO TO 30 DO 22 L = 2,N I = 1 JMAX = MIN0(N,JMIN + MM1) DO 21 J = JMIN,JMAX IF (A(I,J) .NE. (0.0,0.0)) GO TO 30 21 I = I + 1 JMIN = JMIN - 1 22 CONTINUE C 30 ML = IMIN - 1 MU = JMIN - 1 KMAX = ML + MU + 1 IF (KMAX .GT. NB) GO TO 40 C C STORE THE MATRIX IN B C IERR = 0 CALL CVCB (A,KA,M,N,ML,MU,B,KB) RETURN C C ERROR RETURN C 40 IERR = KMAX RETURN END SUBROUTINE MCVBS (A,KA,M,N,ML,MU,B,IB,JB,NUM,IERR) C----------------------------------------------------------------------- C CONVERSION OF REAL MATRICES FROM BANDED C TO SPARSE FORM C----------------------------------------------------------------------- REAL A(KA,*), B(*) INTEGER IB(*), JB(*) C L = 1 KMAX = ML + MU + 1 C C STORE THE NONZERO DATA OF THE FIRST ML ROWS C J0 = ML IF (ML .EQ. 0) GO TO 20 DO 11 I = 1,ML IB(I) = L KMIN = 1 + J0 DO 10 K = KMIN,KMAX IF (A(I,K) .EQ. 0.0) GO TO 10 IF (L .GT. NUM) GO TO 40 B(L) = A(I,K) JB(L) = K - J0 L = L + 1 10 CONTINUE J0 = J0 - 1 11 CONTINUE C C STORE THE REMAINING NONZERO DATA C 20 IMIN = ML + 1 IMAX = MIN0(M,ML + N) DO 22 I = IMIN,IMAX IB(I) = L DO 21 K = 1,KMAX IF (A(I,K) .EQ. 0.0) GO TO 21 IF (L .GT. NUM) GO TO 40 B(L) = A(I,K) JB(L) = K - J0 L = L + 1 21 CONTINUE J0 = J0 - 1 22 CONTINUE IERR = 0 C C SET UP THE REMAINING M-IMAX ROWS C IMIN = IMAX + 1 MP1 = M + 1 DO 30 I = IMIN,MP1 IB(I) = L 30 CONTINUE RETURN C C ERROR RETURN C 40 IERR = I RETURN END SUBROUTINE DMCVBS (A,KA,M,N,ML,MU,B,IB,JB,NUM,IERR) C----------------------------------------------------------------------- C CONVERSION OF DOUBLE PRECISION MATRICES FROM BANDED C TO SPARSE FORM C----------------------------------------------------------------------- DOUBLE PRECISION A(KA,*), B(*) INTEGER IB(*), JB(*) C L = 1 KMAX = ML + MU + 1 C C STORE THE NONZERO DATA OF THE FIRST ML ROWS C J0 = ML IF (ML .EQ. 0) GO TO 20 DO 11 I = 1,ML IB(I) = L KMIN = 1 + J0 DO 10 K = KMIN,KMAX IF (A(I,K) .EQ. 0.D0) GO TO 10 IF (L .GT. NUM) GO TO 40 B(L) = A(I,K) JB(L) = K - J0 L = L + 1 10 CONTINUE J0 = J0 - 1 11 CONTINUE C C STORE THE REMAINING NONZERO DATA C 20 IMIN = ML + 1 IMAX = MIN0(M,ML + N) DO 22 I = IMIN,IMAX IB(I) = L DO 21 K = 1,KMAX IF (A(I,K) .EQ. 0.D0) GO TO 21 IF (L .GT. NUM) GO TO 40 B(L) = A(I,K) JB(L) = K - J0 L = L + 1 21 CONTINUE J0 = J0 - 1 22 CONTINUE IERR = 0 C C SET UP THE REMAINING M-IMAX ROWS C IMIN = IMAX + 1 MP1 = M + 1 DO 30 I = IMIN,MP1 IB(I) = L 30 CONTINUE RETURN C C ERROR RETURN C 40 IERR = I RETURN END SUBROUTINE CMCVBS (A,KA,M,N,ML,MU,B,IB,JB,NUM,IERR) C----------------------------------------------------------------------- C CONVERSION OF COMPLEX MATRICES FROM BANDED C TO SPARSE FORM C----------------------------------------------------------------------- COMPLEX A(KA,*), B(*) INTEGER IB(*), JB(*) C L = 1 KMAX = ML + MU + 1 C C STORE THE NONZERO DATA OF THE FIRST ML ROWS C J0 = ML IF (ML .EQ. 0) GO TO 20 DO 11 I = 1,ML IB(I) = L KMIN = 1 + J0 DO 10 K = KMIN,KMAX IF (A(I,K) .EQ. (0.0,0.0)) GO TO 10 IF (L .GT. NUM) GO TO 40 B(L) = A(I,K) JB(L) = K - J0 L = L + 1 10 CONTINUE J0 = J0 - 1 11 CONTINUE C C STORE THE REMAINING NONZERO DATA C 20 IMIN = ML + 1 IMAX = MIN0(M,ML + N) DO 22 I = IMIN,IMAX IB(I) = L DO 21 K = 1,KMAX IF (A(I,K) .EQ. (0.0,0.0)) GO TO 21 IF (L .GT. NUM) GO TO 40 B(L) = A(I,K) JB(L) = K - J0 L = L + 1 21 CONTINUE J0 = J0 - 1 22 CONTINUE IERR = 0 C C SET UP THE REMAINING M-IMAX ROWS C IMIN = IMAX + 1 MP1 = M + 1 DO 30 I = IMIN,MP1 IB(I) = L 30 CONTINUE RETURN C C ERROR RETURN C 40 IERR = I RETURN END SUBROUTINE MCVSB (A,IA,JA,M,N,B,KB,NB,ML,MU,IERR) C----------------------------------------------------------------------- C CONVERSION OF REAL MATRICES FROM SPARSE C TO BANDED FORM C----------------------------------------------------------------------- REAL A(*), B(KB,NB) INTEGER IA(*), JA(*) C C COMPUTATION OF ML AND MU C ML = 0 MU = 0 DO 11 I = 1,M LMIN = IA(I) LMAX = IA(I + 1) - 1 IF (LMIN .GT. LMAX) GO TO 11 DO 10 L = LMIN,LMAX IF (A(L) .EQ. 0.0) GO TO 10 K = JA(L) - I MU = MAX0(MU,K) ML = MAX0(ML,-K) 10 CONTINUE 11 CONTINUE C C SET B = 0 IF B PROVIDES SUFFICIENT STORAGE C KMAX = ML + MU + 1 IF (KMAX .GT. NB) GO TO 40 C IERR = 0 DO 21 K = 1,KMAX DO 20 I = 1,M 20 B(I,K) = 0.0 21 CONTINUE C C STORE THE MATRIX IN B C J0 = ML DO 31 I = 1,M LMIN = IA(I) LMAX = IA(I + 1) - 1 IF (LMIN .GT. LMAX) GO TO 31 DO 30 L = LMIN,LMAX IF (A(L) .EQ. 0.0) GO TO 30 K = JA(L) + J0 B(I,K) = A(L) 30 CONTINUE J0 = J0 - 1 31 CONTINUE RETURN C C ERROR RETURN C 40 IERR = KMAX RETURN END SUBROUTINE DMCVSB (A,IA,JA,M,N,B,KB,NB,ML,MU,IERR) C----------------------------------------------------------------------- C CONVERSION OF DOUBLE PRECISION MATRICES FROM SPARSE C TO BANDED FORM C----------------------------------------------------------------------- DOUBLE PRECISION A(*), B(KB,NB) INTEGER IA(*), JA(*) C C COMPUTATION OF ML AND MU C ML = 0 MU = 0 DO 11 I = 1,M LMIN = IA(I) LMAX = IA(I + 1) - 1 IF (LMIN .GT. LMAX) GO TO 11 DO 10 L = LMIN,LMAX IF (A(L) .EQ. 0.D0) GO TO 10 K = JA(L) - I MU = MAX0(MU,K) ML = MAX0(ML,-K) 10 CONTINUE 11 CONTINUE C C SET B = 0 IF B PROVIDES SUFFICIENT STORAGE C KMAX = ML + MU + 1 IF (KMAX .GT. NB) GO TO 40 C IERR = 0 DO 21 K = 1,KMAX DO 20 I = 1,M 20 B(I,K) = 0.D0 21 CONTINUE C C STORE THE MATRIX IN B C J0 = ML DO 31 I = 1,M LMIN = IA(I) LMAX = IA(I + 1) - 1 IF (LMIN .GT. LMAX) GO TO 31 DO 30 L = LMIN,LMAX IF (A(L) .EQ. 0.D0) GO TO 30 K = JA(L) + J0 B(I,K) = A(L) 30 CONTINUE J0 = J0 - 1 31 CONTINUE RETURN C C ERROR RETURN C 40 IERR = KMAX RETURN END SUBROUTINE CMCVSB (A,IA,JA,M,N,B,KB,NB,ML,MU,IERR) C----------------------------------------------------------------------- C CONVERSION OF COMPLEX MATRICES FROM SPARSE C TO BANDED FORM C----------------------------------------------------------------------- COMPLEX A(*), B(KB,NB) INTEGER IA(*), JA(*) C C COMPUTATION OF ML AND MU C ML = 0 MU = 0 DO 11 I = 1,M LMIN = IA(I) LMAX = IA(I + 1) - 1 IF (LMIN .GT. LMAX) GO TO 11 DO 10 L = LMIN,LMAX IF (A(L) .EQ. (0.0,0.0)) GO TO 10 K = JA(L) - I MU = MAX0(MU,K) ML = MAX0(ML,-K) 10 CONTINUE 11 CONTINUE C C SET B = 0 IF B PROVIDES SUFFICIENT STORAGE C KMAX = ML + MU + 1 IF (KMAX .GT. NB) GO TO 40 C IERR = 0 DO 21 K = 1,KMAX DO 20 I = 1,M 20 B(I,K) = (0.0,0.0) 21 CONTINUE C C STORE THE MATRIX IN B C J0 = ML DO 31 I = 1,M LMIN = IA(I) LMAX = IA(I + 1) - 1 IF (LMIN .GT. LMAX) GO TO 31 DO 30 L = LMIN,LMAX IF (A(L) .EQ. (0.0,0.0)) GO TO 30 K = JA(L) + J0 B(I,K) = A(L) 30 CONTINUE J0 = J0 - 1 31 CONTINUE RETURN C C ERROR RETURN C 40 IERR = KMAX RETURN END SUBROUTINE BCVRD (A, KA, M, N, ML, MU, B, KB) C----------------------------------------------------------------------- C CONVERSION OF BANDED MATRICES FROM SINGLE TO DOUBLE C PRECISION FORM C----------------------------------------------------------------------- REAL A(KA,*) DOUBLE PRECISION B(KB,*) C NUM = ML + MU + 1 DO 20 J = 1,NUM DO 10 I = 1,M B(I,J) = A(I,J) 10 CONTINUE 20 CONTINUE RETURN END SUBROUTINE BCVDR (A, KA, M, N, ML, MU, B, KB) C----------------------------------------------------------------------- C CONVERSION OF BANDED MATRICES FROM DOUBLE TO SINGLE C PRECISION FORM C----------------------------------------------------------------------- DOUBLE PRECISION A(KA,*) REAL B(KB,*) C NUM = ML + MU + 1 DO 20 J = 1,NUM DO 10 I = 1,M B(I,J) = A(I,J) 10 CONTINUE 20 CONTINUE RETURN END SUBROUTINE BREAL (A, KA, M, N, ML, MU, B, KB, L, NL, NU, IERR) C----------------------------------------------------------------------- C REAL PART OF A BANDED COMPLEX MATRIX C----------------------------------------------------------------------- COMPLEX A(KA,*) REAL B(KB,L) C C COMPUTATION OF NL AND NU C NL = ML IF (ML .EQ. 0) GO TO 30 IMIN = ML + 1 DO 20 J = 1,ML DO 10 I = IMIN,M IF (REAL(A(I,J)) .NE. 0.0) GO TO 30 10 CONTINUE NL = NL - 1 IMIN = IMIN - 1 20 CONTINUE C 30 NU = MU IF (MU .EQ. 0) GO TO 60 J = ML + MU + 1 DO 50 K = 1,MU DO 40 I = 1,M IF (REAL(A(I,J)) .NE. 0.0) GO TO 60 40 CONTINUE NU = NU - 1 J = J - 1 50 CONTINUE C C STORE THE REAL PART OF A IN B C 60 NUM = NL + NU + 1 IF (NUM .GT. L) GO TO 100 IERR = 0 K = ML - NL DO 80 J = 1,NUM K = K + 1 DO 70 I = 1,M B(I,J) = REAL(A(I,K)) 70 CONTINUE 80 CONTINUE RETURN C C ERROR RETURN C 100 IERR = NUM RETURN END SUBROUTINE BIMAG (A, KA, M, N, ML, MU, B, KB, L, NL, NU, IERR) C----------------------------------------------------------------------- C IMAGINARY PART OF A BANDED COMPLEX MATRIX C----------------------------------------------------------------------- COMPLEX A(KA,*) REAL B(KB,L) C C COMPUTATION OF NL AND NU C NL = ML IF (ML .EQ. 0) GO TO 30 IMIN = ML + 1 DO 20 J = 1,ML DO 10 I = IMIN,M IF (AIMAG(A(I,J)) .NE. 0.0) GO TO 30 10 CONTINUE NL = NL - 1 IMIN = IMIN - 1 20 CONTINUE C 30 NU = MU IF (MU .EQ. 0) GO TO 60 J = ML + MU + 1 DO 50 K = 1,MU DO 40 I = 1,M IF (AIMAG(A(I,J)) .NE. 0.0) GO TO 60 40 CONTINUE NU = NU - 1 J = J - 1 50 CONTINUE C C STORE THE IMAGINARY PART OF A IN B C 60 NUM = NL + NU + 1 IF (NUM .GT. L) GO TO 100 IERR = 0 K = ML - NL DO 80 J = 1,NUM K = K + 1 DO 70 I = 1,M B(I,J) = AIMAG(A(I,K)) 70 CONTINUE 80 CONTINUE RETURN C C ERROR RETURN C 100 IERR = NUM RETURN END SUBROUTINE BCVRC (M,N,A,KA,ML,MU,B,KB,NL,NU,C,KC,L,MCL,MCU,IERR) C----------------------------------------------------------------------- C COMPUTE A + BI FOR THE BANDED REAL MATRICES A AND B C----------------------------------------------------------------------- REAL A(KA,*), B(KB,*) COMPLEX C(KC,L) C MCL = MAX0(ML,NL) MCU = MAX0(MU,NU) NUM = MCL + MCU + 1 IF (NUM .GT. L) GO TO 200 C IERR = 0 K = MIN0(MU,NU) + 1 C C INSERT THE FIRST ABS(ML - NL) DIAGONALS C IF (NL .GE. ML) GO TO 30 JA = ML - NL JB = 0 JC = JA JMAX = NL + K DO 20 J = 1,JC DO 10 I = 1,M C(I,J) = CMPLX(A(I,J),0.0) 10 CONTINUE 20 CONTINUE GO TO 60 C 30 JA = 0 JB = NL - ML JC = JB JMAX = ML + K IF (JC .EQ. 0) GO TO 60 DO 50 J = 1,JC DO 40 I = 1,M C(I,J) = CMPLX(0.0,B(I,J)) 40 CONTINUE 50 CONTINUE C C ADDITION OF THE COMMON DIAGONALS C 60 DO 80 J = 1,JMAX JA = JA + 1 JB = JB + 1 JC = JC + 1 DO 70 I = 1,M C(I,JC) = CMPLX(A(I,JA),B(I,JB)) 70 CONTINUE 80 CONTINUE C C INSERTION OF THE REMAINING DIAGONALS C IF (NU .GE. MU) GO TO 120 JMAX = MU - NU DO 110 J = 1,JMAX JA = JA + 1 JC = JC + 1 DO 100 I = 1,M C(I,JC) = CMPLX(A(I,JA),0.0) 100 CONTINUE 110 CONTINUE RETURN C 120 JMAX = NU - MU IF (JMAX .EQ. 0) RETURN DO 140 J = 1,JMAX JB = JB + 1 JC = JC + 1 DO 130 I = 1,M C(I,JC) = CMPLX(0.0,B(I,JB)) 130 CONTINUE 140 CONTINUE RETURN C C ERROR RETURN C 200 IERR = NUM RETURN END SUBROUTINE BPOSE (A, KA, M, N, ML, MU, B, KB) C----------------------------------------------------------------------- C TRANSPOSITION OF REAL BANDED MATRICES C----------------------------------------------------------------------- REAL A(KA,*), B(KB,*) C L = ML + MU + 1 LP1 = L + 1 IF (MU .EQ. 0) GO TO 40 C C DEFINE THE FIRST MU COLUMNS OF B C NDIAG = MU DO 31 J = 1,MU DO 10 I = 1,NDIAG B(I,J) = 0.0 10 CONTINUE C LJ = LP1 - J IMAX = MIN0(M,N - NDIAG) DO 20 I = 1,IMAX K = NDIAG + I B(K,J) = A(I,LJ) 20 CONTINUE C IF (K .EQ. N) GO TO 31 IMIN = K + 1 DO 30 I = IMIN,N B(I,J) = 0.0 30 CONTINUE 31 NDIAG = NDIAG - 1 C C DEFINE THE REMAINING COLUMNS OF B C 40 JMIN = MU + 1 NDIAG = 0 DO 61 J = JMIN,L LJ = LP1 - J IMAX = MIN0(M - NDIAG,N) DO 50 I = 1,IMAX K = NDIAG + I B(I,J) = A(K,LJ) 50 CONTINUE C IF (IMAX .EQ. N) GO TO 61 IMIN = IMAX + 1 DO 60 I = IMIN,N B(I,J) = 0.0 60 CONTINUE 61 NDIAG = NDIAG + 1 RETURN END SUBROUTINE DBPOSE (A, KA, M, N, ML, MU, B, KB) C----------------------------------------------------------------------- C TRANSPOSITION OF DOUBLE PRECISION BANDED MATRICES C----------------------------------------------------------------------- DOUBLE PRECISION A(KA,*), B(KB,*) C L = ML + MU + 1 LP1 = L + 1 IF (MU .EQ. 0) GO TO 40 C C DEFINE THE FIRST MU COLUMNS OF B C NDIAG = MU DO 31 J = 1,MU DO 10 I = 1,NDIAG B(I,J) = 0.D0 10 CONTINUE C LJ = LP1 - J IMAX = MIN0(M,N - NDIAG) DO 20 I = 1,IMAX K = NDIAG + I B(K,J) = A(I,LJ) 20 CONTINUE C IF (K .EQ. N) GO TO 31 IMIN = K + 1 DO 30 I = IMIN,N B(I,J) = 0.D0 30 CONTINUE 31 NDIAG = NDIAG - 1 C C DEFINE THE REMAINING COLUMNS OF B C 40 JMIN = MU + 1 NDIAG = 0 DO 61 J = JMIN,L LJ = LP1 - J IMAX = MIN0(M - NDIAG,N) DO 50 I = 1,IMAX K = NDIAG + I B(I,J) = A(K,LJ) 50 CONTINUE C IF (IMAX .EQ. N) GO TO 61 IMIN = IMAX + 1 DO 60 I = IMIN,N B(I,J) = 0.D0 60 CONTINUE 61 NDIAG = NDIAG + 1 RETURN END SUBROUTINE CBPOSE (A, KA, M, N, ML, MU, B, KB) C----------------------------------------------------------------------- C TRANSPOSITION OF COMPLEX BANDED MATRICES C----------------------------------------------------------------------- COMPLEX A(KA,*), B(KB,*) C L = ML + MU + 1 LP1 = L + 1 IF (MU .EQ. 0) GO TO 40 C C DEFINE THE FIRST MU COLUMNS OF B C NDIAG = MU DO 31 J = 1,MU DO 10 I = 1,NDIAG B(I,J) = (0.0,0.0) 10 CONTINUE C LJ = LP1 - J IMAX = MIN0(M,N - NDIAG) DO 20 I = 1,IMAX K = NDIAG + I B(K,J) = A(I,LJ) 20 CONTINUE C IF (K .EQ. N) GO TO 31 IMIN = K + 1 DO 30 I = IMIN,N B(I,J) = (0.0,0.0) 30 CONTINUE 31 NDIAG = NDIAG - 1 C C DEFINE THE REMAINING COLUMNS OF B C 40 JMIN = MU + 1 NDIAG = 0 DO 61 J = JMIN,L LJ = LP1 - J IMAX = MIN0(M - NDIAG,N) DO 50 I = 1,IMAX K = NDIAG + I B(I,J) = A(K,LJ) 50 CONTINUE C IF (IMAX .EQ. N) GO TO 61 IMIN = IMAX + 1 DO 60 I = IMIN,N B(I,J) = (0.0,0.0) 60 CONTINUE 61 NDIAG = NDIAG + 1 RETURN END SUBROUTINE BADD (M,N,A,KA,ML,MU,B,KB,NL,NU,C,KC,L,MCL,MCU,IERR) C----------------------------------------------------------------------- C ADDITION OF REAL BANDED MATRICES C----------------------------------------------------------------------- REAL A(KA,*), B(KB,*), C(KC,L) C IERR = 0 IF (NL - ML) 10,30,20 C C INSERT THE FIRST ABS(ML - NL) DIAGONALS C 10 MCL = ML IF (ML .GE. L) GO TO 50 JA = ML - NL JB = 0 JC = JA JMAX = NL + 1 DO 12 J = 1,JC DO 11 I = 1,M 11 C(I,J) = A(I,J) 12 CONTINUE GO TO 50 C 20 MCL = NL IF (NL .GE. L) GO TO 50 JA = 0 JB = NL - ML JC = JB JMAX = ML + 1 DO 22 J = 1,JC DO 21 I = 1,M 21 C(I,J) = B(I,J) 22 CONTINUE GO TO 50 C C COMPUTE MCL WHEN ML = NL C 30 MCL = ML IF (ML .EQ. 0) GO TO 40 IMIN = ML + 1 DO 32 J = 1,ML DO 31 I = IMIN,M IF ((A(I,J) + B(I,J)) .NE. 0.0) GO TO 40 31 CONTINUE MCL = MCL - 1 IMIN = IMIN - 1 32 CONTINUE C 40 JA = ML - MCL JB = JA JC = 0 JMAX = MCL + 1 C 50 IF (NU - MU) 100,160,130 C C INSERTION OF THE REMAINING DIAGONALS WHEN MU .NE. NU C 100 MCU = MU NUM = MCL + MCU + 1 IF (NUM .GT. L) GO TO 200 C JMAX = JMAX + NU DO 111 J = 1,JMAX JA = JA + 1 JB = JB + 1 JC = JC + 1 DO 110 I = 1,M C(I,JC) = A(I,JA) + B(I,JB) 110 CONTINUE 111 CONTINUE C JMAX = MU - NU DO 121 J = 1,JMAX JA = JA + 1 JC = JC + 1 DO 120 I = 1,M 120 C(I,JC) = A(I,JA) 121 CONTINUE RETURN C 130 MCU = NU NUM = MCL + MCU + 1 IF (NUM .GT. L) GO TO 200 C JMAX = JMAX + MU DO 141 J = 1,JMAX JA = JA + 1 JB = JB + 1 JC = JC + 1 DO 140 I = 1,M C(I,JC) = A(I,JA) + B(I,JB) 140 CONTINUE 141 CONTINUE C JMAX = NU - MU DO 151 J = 1,JMAX JB = JB + 1 JC = JC + 1 DO 150 I = 1,M 150 C(I,JC) = B(I,JB) 151 CONTINUE RETURN C C COMPUTE MCU WHEN MU = NU C 160 MCU = MU IF (MU .EQ. 0) GO TO 170 LA = ML + MU + 1 LB = NL + NU + 1 DO 162 J = 1,MU DO 161 I = 1,M IF ((A(I,LA) + B(I,LB)) .NE. 0.0) GO TO 170 161 CONTINUE MCU = MCU - 1 LA = LA - 1 LB = LB - 1 162 CONTINUE C C ADDITION OF THE REMAINING COLUMNS WHEN MU = NU C 170 NUM = MCL + MCU + 1 IF (NUM .GT. L) GO TO 200 C JMAX = JMAX + MCU DO 181 J = 1,JMAX JA = JA + 1 JB = JB + 1 JC = JC + 1 DO 180 I = 1,M C(I,JC) = A(I,JA) + B(I,JB) 180 CONTINUE 181 CONTINUE RETURN C C ERROR RETURN C 200 IERR = NUM RETURN END SUBROUTINE DBADD (M,N,A,KA,ML,MU,B,KB,NL,NU,C,KC,L,MCL,MCU,IERR) C----------------------------------------------------------------------- C ADDITION OF DOUBLE PRECISION BANDED MATRICES C----------------------------------------------------------------------- DOUBLE PRECISION A(KA,*), B(KB,*), C(KC,L) C IERR = 0 IF (NL - ML) 10,30,20 C C INSERT THE FIRST ABS(ML - NL) DIAGONALS C 10 MCL = ML IF (ML .GE. L) GO TO 50 JA = ML - NL JB = 0 JC = JA JMAX = NL + 1 DO 12 J = 1,JC DO 11 I = 1,M 11 C(I,J) = A(I,J) 12 CONTINUE GO TO 50 C 20 MCL = NL IF (NL .GE. L) GO TO 50 JA = 0 JB = NL - ML JC = JB JMAX = ML + 1 DO 22 J = 1,JC DO 21 I = 1,M 21 C(I,J) = B(I,J) 22 CONTINUE GO TO 50 C C COMPUTE MCL WHEN ML = NL C 30 MCL = ML IF (ML .EQ. 0) GO TO 40 IMIN = ML + 1 DO 32 J = 1,ML DO 31 I = IMIN,M IF ((A(I,J) + B(I,J)) .NE. 0.D0) GO TO 40 31 CONTINUE MCL = MCL - 1 IMIN = IMIN - 1 32 CONTINUE C 40 JA = ML - MCL JB = JA JC = 0 JMAX = MCL + 1 C 50 IF (NU - MU) 100,160,130 C C INSERTION OF THE REMAINING DIAGONALS WHEN MU .NE. NU C 100 MCU = MU NUM = MCL + MCU + 1 IF (NUM .GT. L) GO TO 200 C JMAX = JMAX + NU DO 111 J = 1,JMAX JA = JA + 1 JB = JB + 1 JC = JC + 1 DO 110 I = 1,M C(I,JC) = A(I,JA) + B(I,JB) 110 CONTINUE 111 CONTINUE C JMAX = MU - NU DO 121 J = 1,JMAX JA = JA + 1 JC = JC + 1 DO 120 I = 1,M 120 C(I,JC) = A(I,JA) 121 CONTINUE RETURN C 130 MCU = NU NUM = MCL + MCU + 1 IF (NUM .GT. L) GO TO 200 C JMAX = JMAX + MU DO 141 J = 1,JMAX JA = JA + 1 JB = JB + 1 JC = JC + 1 DO 140 I = 1,M C(I,JC) = A(I,JA) + B(I,JB) 140 CONTINUE 141 CONTINUE C JMAX = NU - MU DO 151 J = 1,JMAX JB = JB + 1 JC = JC + 1 DO 150 I = 1,M 150 C(I,JC) = B(I,JB) 151 CONTINUE RETURN C C COMPUTE MCU WHEN MU = NU C 160 MCU = MU IF (MU .EQ. 0) GO TO 170 LA = ML + MU + 1 LB = NL + NU + 1 DO 162 J = 1,MU DO 161 I = 1,M IF ((A(I,LA) + B(I,LB)) .NE. 0.D0) GO TO 170 161 CONTINUE MCU = MCU - 1 LA = LA - 1 LB = LB - 1 162 CONTINUE C C ADDITION OF THE REMAINING COLUMNS WHEN MU = NU C 170 NUM = MCL + MCU + 1 IF (NUM .GT. L) GO TO 200 C JMAX = JMAX + MCU DO 181 J = 1,JMAX JA = JA + 1 JB = JB + 1 JC = JC + 1 DO 180 I = 1,M C(I,JC) = A(I,JA) + B(I,JB) 180 CONTINUE 181 CONTINUE RETURN C C ERROR RETURN C 200 IERR = NUM RETURN END SUBROUTINE CBADD (M,N,A,KA,ML,MU,B,KB,NL,NU,C,KC,L,MCL,MCU,IERR) C----------------------------------------------------------------------- C ADDITION OF COMPLEX BANDED MATRICES C----------------------------------------------------------------------- COMPLEX A(KA,*), B(KB,*), C(KC,L) C IERR = 0 IF (NL - ML) 10,30,20 C C INSERT THE FIRST ABS(ML - NL) DIAGONALS C 10 MCL = ML IF (ML .GE. L) GO TO 50 JA = ML - NL JB = 0 JC = JA JMAX = NL + 1 DO 12 J = 1,JC DO 11 I = 1,M 11 C(I,J) = A(I,J) 12 CONTINUE GO TO 50 C 20 MCL = NL IF (NL .GE. L) GO TO 50 JA = 0 JB = NL - ML JC = JB JMAX = ML + 1 DO 22 J = 1,JC DO 21 I = 1,M 21 C(I,J) = B(I,J) 22 CONTINUE GO TO 50 C C COMPUTE MCL WHEN ML = NL C 30 MCL = ML IF (ML .EQ. 0) GO TO 40 IMIN = ML + 1 DO 32 J = 1,ML DO 31 I = IMIN,M IF ((A(I,J) + B(I,J)) .NE. (0.0,0.0)) GO TO 40 31 CONTINUE MCL = MCL - 1 IMIN = IMIN - 1 32 CONTINUE C 40 JA = ML - MCL JB = JA JC = 0 JMAX = MCL + 1 C 50 IF (NU - MU) 100,160,130 C C INSERTION OF THE REMAINING DIAGONALS WHEN MU .NE. NU C 100 MCU = MU NUM = MCL + MCU + 1 IF (NUM .GT. L) GO TO 200 C JMAX = JMAX + NU DO 111 J = 1,JMAX JA = JA + 1 JB = JB + 1 JC = JC + 1 DO 110 I = 1,M C(I,JC) = A(I,JA) + B(I,JB) 110 CONTINUE 111 CONTINUE C JMAX = MU - NU DO 121 J = 1,JMAX JA = JA + 1 JC = JC + 1 DO 120 I = 1,M 120 C(I,JC) = A(I,JA) 121 CONTINUE RETURN C 130 MCU = NU NUM = MCL + MCU + 1 IF (NUM .GT. L) GO TO 200 C JMAX = JMAX + MU DO 141 J = 1,JMAX JA = JA + 1 JB = JB + 1 JC = JC + 1 DO 140 I = 1,M C(I,JC) = A(I,JA) + B(I,JB) 140 CONTINUE 141 CONTINUE C JMAX = NU - MU DO 151 J = 1,JMAX JB = JB + 1 JC = JC + 1 DO 150 I = 1,M 150 C(I,JC) = B(I,JB) 151 CONTINUE RETURN C C COMPUTE MCU WHEN MU = NU C 160 MCU = MU IF (MU .EQ. 0) GO TO 170 LA = ML + MU + 1 LB = NL + NU + 1 DO 162 J = 1,MU DO 161 I = 1,M IF ((A(I,LA) + B(I,LB)) .NE. (0.0,0.0)) GO TO 170 161 CONTINUE MCU = MCU - 1 LA = LA - 1 LB = LB - 1 162 CONTINUE C C ADDITION OF THE REMAINING COLUMNS WHEN MU = NU C 170 NUM = MCL + MCU + 1 IF (NUM .GT. L) GO TO 200 C JMAX = JMAX + MCU DO 181 J = 1,JMAX JA = JA + 1 JB = JB + 1 JC = JC + 1 DO 180 I = 1,M C(I,JC) = A(I,JA) + B(I,JB) 180 CONTINUE 181 CONTINUE RETURN C C ERROR RETURN C 200 IERR = NUM RETURN END SUBROUTINE BSUBT (M,N,A,KA,ML,MU,B,KB,NL,NU,C,KC,L,MCL,MCU,IERR) C----------------------------------------------------------------------- C SUBTRACTION OF REAL BANDED MATRICES C----------------------------------------------------------------------- REAL A(KA,*), B(KB,*), C(KC,L) C IERR = 0 IF (NL - ML) 10,30,20 C C INSERT THE FIRST ABS(ML - NL) DIAGONALS C 10 MCL = ML IF (ML .GE. L) GO TO 50 JA = ML - NL JB = 0 JC = JA JMAX = NL + 1 DO 12 J = 1,JC DO 11 I = 1,M 11 C(I,J) = A(I,J) 12 CONTINUE GO TO 50 C 20 MCL = NL IF (NL .GE. L) GO TO 50 JA = 0 JB = NL - ML JC = JB JMAX = ML + 1 DO 22 J = 1,JC DO 21 I = 1,M 21 C(I,J) = -B(I,J) 22 CONTINUE GO TO 50 C C COMPUTE MCL WHEN ML = NL C 30 MCL = ML IF (ML .EQ. 0) GO TO 40 IMIN = ML + 1 DO 32 J = 1,ML DO 31 I = IMIN,M IF ((A(I,J) - B(I,J)) .NE. 0.0) GO TO 40 31 CONTINUE MCL = MCL - 1 IMIN = IMIN - 1 32 CONTINUE C 40 JA = ML - MCL JB = JA JC = 0 JMAX = MCL + 1 C 50 IF (NU - MU) 100,160,130 C C INSERTION OF THE REMAINING DIAGONALS WHEN MU .NE. NU C 100 MCU = MU NUM = MCL + MCU + 1 IF (NUM .GT. L) GO TO 200 C JMAX = JMAX + NU DO 111 J = 1,JMAX JA = JA + 1 JB = JB + 1 JC = JC + 1 DO 110 I = 1,M C(I,JC) = A(I,JA) - B(I,JB) 110 CONTINUE 111 CONTINUE C JMAX = MU - NU DO 121 J = 1,JMAX JA = JA + 1 JC = JC + 1 DO 120 I = 1,M 120 C(I,JC) = A(I,JA) 121 CONTINUE RETURN C 130 MCU = NU NUM = MCL + MCU + 1 IF (NUM .GT. L) GO TO 200 C JMAX = JMAX + MU DO 141 J = 1,JMAX JA = JA + 1 JB = JB + 1 JC = JC + 1 DO 140 I = 1,M C(I,JC) = A(I,JA) - B(I,JB) 140 CONTINUE 141 CONTINUE C JMAX = NU - MU DO 151 J = 1,JMAX JB = JB + 1 JC = JC + 1 DO 150 I = 1,M 150 C(I,JC) = -B(I,JB) 151 CONTINUE RETURN C C COMPUTE MCU WHEN MU = NU C 160 MCU = MU IF (MU .EQ. 0) GO TO 170 LA = ML + MU + 1 LB = NL + NU + 1 DO 162 J = 1,MU DO 161 I = 1,M IF ((A(I,LA) - B(I,LB)) .NE. 0.0) GO TO 170 161 CONTINUE MCU = MCU - 1 LA = LA - 1 LB = LB - 1 162 CONTINUE C C ADDITION OF THE REMAINING COLUMNS WHEN MU = NU C 170 NUM = MCL + MCU + 1 IF (NUM .GT. L) GO TO 200 C JMAX = JMAX + MCU DO 181 J = 1,JMAX JA = JA + 1 JB = JB + 1 JC = JC + 1 DO 180 I = 1,M C(I,JC) = A(I,JA) - B(I,JB) 180 CONTINUE 181 CONTINUE RETURN C C ERROR RETURN C 200 IERR = NUM RETURN END SUBROUTINE DBSUBT (M,N,A,KA,ML,MU,B,KB,NL,NU,C,KC,L,MCL,MCU,IERR) C----------------------------------------------------------------------- C SUBTRACTION OF DOUBLE PRECISION BANDED MATRICES C----------------------------------------------------------------------- DOUBLE PRECISION A(KA,*), B(KB,*), C(KC,L) C IERR = 0 IF (NL - ML) 10,30,20 C C INSERT THE FIRST ABS(ML - NL) DIAGONALS C 10 MCL = ML IF (ML .GE. L) GO TO 50 JA = ML - NL JB = 0 JC = JA JMAX = NL + 1 DO 12 J = 1,JC DO 11 I = 1,M 11 C(I,J) = A(I,J) 12 CONTINUE GO TO 50 C 20 MCL = NL IF (NL .GE. L) GO TO 50 JA = 0 JB = NL - ML JC = JB JMAX = ML + 1 DO 22 J = 1,JC DO 21 I = 1,M 21 C(I,J) = -B(I,J) 22 CONTINUE GO TO 50 C C COMPUTE MCL WHEN ML = NL C 30 MCL = ML IF (ML .EQ. 0) GO TO 40 IMIN = ML + 1 DO 32 J = 1,ML DO 31 I = IMIN,M IF ((A(I,J) - B(I,J)) .NE. 0.D0) GO TO 40 31 CONTINUE MCL = MCL - 1 IMIN = IMIN - 1 32 CONTINUE C 40 JA = ML - MCL JB = JA JC = 0 JMAX = MCL + 1 C 50 IF (NU - MU) 100,160,130 C C INSERTION OF THE REMAINING DIAGONALS WHEN MU .NE. NU C 100 MCU = MU NUM = MCL + MCU + 1 IF (NUM .GT. L) GO TO 200 C JMAX = JMAX + NU DO 111 J = 1,JMAX JA = JA + 1 JB = JB + 1 JC = JC + 1 DO 110 I = 1,M C(I,JC) = A(I,JA) - B(I,JB) 110 CONTINUE 111 CONTINUE C JMAX = MU - NU DO 121 J = 1,JMAX JA = JA + 1 JC = JC + 1 DO 120 I = 1,M 120 C(I,JC) = A(I,JA) 121 CONTINUE RETURN C 130 MCU = NU NUM = MCL + MCU + 1 IF (NUM .GT. L) GO TO 200 C JMAX = JMAX + MU DO 141 J = 1,JMAX JA = JA + 1 JB = JB + 1 JC = JC + 1 DO 140 I = 1,M C(I,JC) = A(I,JA) - B(I,JB) 140 CONTINUE 141 CONTINUE C JMAX = NU - MU DO 151 J = 1,JMAX JB = JB + 1 JC = JC + 1 DO 150 I = 1,M 150 C(I,JC) = -B(I,JB) 151 CONTINUE RETURN C C COMPUTE MCU WHEN MU = NU C 160 MCU = MU IF (MU .EQ. 0) GO TO 170 LA = ML + MU + 1 LB = NL + NU + 1 DO 162 J = 1,MU DO 161 I = 1,M IF ((A(I,LA) - B(I,LB)) .NE. 0.D0) GO TO 170 161 CONTINUE MCU = MCU - 1 LA = LA - 1 LB = LB - 1 162 CONTINUE C C ADDITION OF THE REMAINING COLUMNS WHEN MU = NU C 170 NUM = MCL + MCU + 1 IF (NUM .GT. L) GO TO 200 C JMAX = JMAX + MCU DO 181 J = 1,JMAX JA = JA + 1 JB = JB + 1 JC = JC + 1 DO 180 I = 1,M C(I,JC) = A(I,JA) - B(I,JB) 180 CONTINUE 181 CONTINUE RETURN C C ERROR RETURN C 200 IERR = NUM RETURN END SUBROUTINE CBSUBT (M,N,A,KA,ML,MU,B,KB,NL,NU,C,KC,L,MCL,MCU,IERR) C----------------------------------------------------------------------- C SUBTRACTION OF COMPLEX BANDED MATRICES C----------------------------------------------------------------------- COMPLEX A(KA,*), B(KB,*), C(KC,L) C IERR = 0 IF (NL - ML) 10,30,20 C C INSERT THE FIRST ABS(ML - NL) DIAGONALS C 10 MCL = ML IF (ML .GE. L) GO TO 50 JA = ML - NL JB = 0 JC = JA JMAX = NL + 1 DO 12 J = 1,JC DO 11 I = 1,M 11 C(I,J) = A(I,J) 12 CONTINUE GO TO 50 C 20 MCL = NL IF (NL .GE. L) GO TO 50 JA = 0 JB = NL - ML JC = JB JMAX = ML + 1 DO 22 J = 1,JC DO 21 I = 1,M 21 C(I,J) = -B(I,J) 22 CONTINUE GO TO 50 C C COMPUTE MCL WHEN ML = NL C 30 MCL = ML IF (ML .EQ. 0) GO TO 40 IMIN = ML + 1 DO 32 J = 1,ML DO 31 I = IMIN,M IF ((A(I,J) - B(I,J)) .NE. (0.0,0.0)) GO TO 40 31 CONTINUE MCL = MCL - 1 IMIN = IMIN - 1 32 CONTINUE C 40 JA = ML - MCL JB = JA JC = 0 JMAX = MCL + 1 C 50 IF (NU - MU) 100,160,130 C C INSERTION OF THE REMAINING DIAGONALS WHEN MU .NE. NU C 100 MCU = MU NUM = MCL + MCU + 1 IF (NUM .GT. L) GO TO 200 C JMAX = JMAX + NU DO 111 J = 1,JMAX JA = JA + 1 JB = JB + 1 JC = JC + 1 DO 110 I = 1,M C(I,JC) = A(I,JA) - B(I,JB) 110 CONTINUE 111 CONTINUE C JMAX = MU - NU DO 121 J = 1,JMAX JA = JA + 1 JC = JC + 1 DO 120 I = 1,M 120 C(I,JC) = A(I,JA) 121 CONTINUE RETURN C 130 MCU = NU NUM = MCL + MCU + 1 IF (NUM .GT. L) GO TO 200 C JMAX = JMAX + MU DO 141 J = 1,JMAX JA = JA + 1 JB = JB + 1 JC = JC + 1 DO 140 I = 1,M C(I,JC) = A(I,JA) - B(I,JB) 140 CONTINUE 141 CONTINUE C JMAX = NU - MU DO 151 J = 1,JMAX JB = JB + 1 JC = JC + 1 DO 150 I = 1,M 150 C(I,JC) = -B(I,JB) 151 CONTINUE RETURN C C COMPUTE MCU WHEN MU = NU C 160 MCU = MU IF (MU .EQ. 0) GO TO 170 LA = ML + MU + 1 LB = NL + NU + 1 DO 162 J = 1,MU DO 161 I = 1,M IF ((A(I,LA) - B(I,LB)) .NE. (0.0,0.0)) GO TO 170 161 CONTINUE MCU = MCU - 1 LA = LA - 1 LB = LB - 1 162 CONTINUE C C ADDITION OF THE REMAINING COLUMNS WHEN MU = NU C 170 NUM = MCL + MCU + 1 IF (NUM .GT. L) GO TO 200 C JMAX = JMAX + MCU DO 181 J = 1,JMAX JA = JA + 1 JB = JB + 1 JC = JC + 1 DO 180 I = 1,M C(I,JC) = A(I,JA) - B(I,JB) 180 CONTINUE 181 CONTINUE RETURN C C ERROR RETURN C 200 IERR = NUM RETURN END SUBROUTINE BPROD (M, N, L, A, KA, ML, MU, B, KB, NL, NU, * C, KC, NC, MCL, MCU, IERR) C----------------------------------------------------------------------- C MULTIPLICATION OF REAL BANDED MATRICES C----------------------------------------------------------------------- REAL A(KA,*), B(KB,*), C(KC,NC) C IERR = 0 DO 11 J = 1,NC DO 10 I = 1,M 10 C(I,J) = 0.0 11 CONTINUE C MLP1 = ML + 1 NLP1 = NL + 1 NPML = N + ML NPNU = N + NU MCL = MIN0(M - 1,ML + NL) JC = 0 IF (MCL .EQ. 0) GO TO 100 C C FIND THE FIRST NONZERO LOWER DIAGONAL C MAXD = MCL DO 31 NDIAG = 1,MAXD IMJ = MAXD + 1 - NDIAG JMAX = MIN0(L,M - IMJ,NPML - IMJ,NPNU) DO 21 J = 1,JMAX I = J + IMJ SUM = 0.0 KMIN = MAX0(1,I - ML,J - NU) KMAX = MIN0(N,I + MU,J + NL) KK = MLP1 - I + KMIN JJ = NLP1 + J - KMIN DO 20 K = KMIN,KMAX SUM = SUM + A(I,KK)*B(K,JJ) KK = KK + 1 JJ = JJ - 1 20 CONTINUE C(I,1) = SUM 21 CONTINUE C DO 30 J = 1,JMAX I = J + IMJ IF (C(I,1) .NE. 0.0) GO TO 40 30 CONTINUE MCL = MCL - 1 31 CONTINUE GO TO 100 C 40 IF (MCL .GE. NC) GO TO 100 JC = 1 IF (MCL .EQ. 1) GO TO 100 C C COMPUTE THE REMAINING LOWER DIAGONALS C MIND = NDIAG + 1 DO 52 NDIAG = MIND,MAXD JC = JC + 1 IMJ = MAXD + 1 - NDIAG JMAX = MIN0(L,M - IMJ,NPML - IMJ,NPNU) DO 51 J = 1,JMAX I = J + IMJ SUM = 0.0 KMIN = MAX0(1,I - ML,J - NU) KMAX = MIN0(N,I + MU,J + NL) KK = MLP1 - I + KMIN JJ = NLP1 + J - KMIN DO 50 K = KMIN,KMAX SUM = SUM + A(I,KK)*B(K,JJ) KK = KK + 1 JJ = JJ - 1 50 CONTINUE C(I,JC) = SUM 51 CONTINUE 52 CONTINUE C C FIND THE LAST NONZERO UPPER DIAGONAL C 100 JC = JC + 1 MCU = MIN0(L - 1,MU + NU) IF (MCU .EQ. 0) GO TO 130 C MAXD = MCU DO 121 NDIAG = 1,MAXD JMI = MAXD + 1 - NDIAG IMAX = MIN0(M,L - JMI,NPML,NPNU - JMI) DO 111 I = 1,IMAX J = I + JMI SUM = 0.0 KMIN = MAX0(1,I - ML,J - NU) KMAX = MIN0(N,I + MU,J + NL) KK = MLP1 - I + KMIN JJ = NLP1 + J - KMIN DO 110 K = KMIN,KMAX SUM = SUM + A(I,KK)*B(K,JJ) KK = KK + 1 JJ = JJ - 1 110 CONTINUE C(I,JC) = SUM 111 CONTINUE C DO 120 I = 1,IMAX IF (C(I,JC) .NE. 0.0) GO TO 130 120 CONTINUE MCU = MCU - 1 121 CONTINUE C 130 LAST = MCL + MCU + 1 IF (LAST .GT. NC) GO TO 200 IF (MCU .EQ. 0) GO TO 140 DO 131 I = 1,IMAX C(I,LAST) = C(I,JC) C(I,JC) = 0.0 131 CONTINUE C C COMPUTE THE MAIN DIAGONAL AND THE REMAINING UPPER DIAGONALS C 140 MAXD = MAX0(1,MCU) DO 143 NDIAG = 1,MAXD JMI = NDIAG - 1 IMAX = MIN0(M,L - JMI,NPML,NPNU - JMI) DO 142 I = 1,IMAX J = I + JMI SUM = 0.0 KMIN = MAX0(1,I - ML,J - NU) KMAX = MIN0(N,I + MU,J + NL) KK = MLP1 - I + KMIN JJ = NLP1 + J - KMIN DO 141 K = KMIN,KMAX SUM = SUM + A(I,KK)*B(K,JJ) KK = KK + 1 JJ = JJ - 1 141 CONTINUE C(I,JC) = SUM 142 CONTINUE JC = JC + 1 143 CONTINUE RETURN C C ERROR RETURN C 200 IERR = LAST RETURN END SUBROUTINE DBPROD (M, N, L, A, KA, ML, MU, B, KB, NL, NU, * C, KC, NC, MCL, MCU, IERR) C----------------------------------------------------------------------- C MULTIPLICATION OF DOUBLE PRECISION BANDED MATRICES C----------------------------------------------------------------------- DOUBLE PRECISION A(KA,*), B(KB,*), C(KC,NC) DOUBLE PRECISION SUM C IERR = 0 DO 11 J = 1,NC DO 10 I = 1,M 10 C(I,J) = 0.D0 11 CONTINUE C MLP1 = ML + 1 NLP1 = NL + 1 NPML = N + ML NPNU = N + NU MCL = MIN0(M - 1,ML + NL) JC = 0 IF (MCL .EQ. 0) GO TO 100 C C FIND THE FIRST NONZERO LOWER DIAGONAL C MAXD = MCL DO 31 NDIAG = 1,MAXD IMJ = MAXD + 1 - NDIAG JMAX = MIN0(L,M - IMJ,NPML - IMJ,NPNU) DO 21 J = 1,JMAX I = J + IMJ SUM = 0.D0 KMIN = MAX0(1,I - ML,J - NU) KMAX = MIN0(N,I + MU,J + NL) KK = MLP1 - I + KMIN JJ = NLP1 + J - KMIN DO 20 K = KMIN,KMAX SUM = SUM + A(I,KK)*B(K,JJ) KK = KK + 1 JJ = JJ - 1 20 CONTINUE C(I,1) = SUM 21 CONTINUE C DO 30 J = 1,JMAX I = J + IMJ IF (C(I,1) .NE. 0.D0) GO TO 40 30 CONTINUE MCL = MCL - 1 31 CONTINUE GO TO 100 C 40 IF (MCL .GE. NC) GO TO 100 JC = 1 IF (MCL .EQ. 1) GO TO 100 C C COMPUTE THE REMAINING LOWER DIAGONALS C MIND = NDIAG + 1 DO 52 NDIAG = MIND,MAXD JC = JC + 1 IMJ = MAXD + 1 - NDIAG JMAX = MIN0(L,M - IMJ,NPML - IMJ,NPNU) DO 51 J = 1,JMAX I = J + IMJ SUM = 0.D0 KMIN = MAX0(1,I - ML,J - NU) KMAX = MIN0(N,I + MU,J + NL) KK = MLP1 - I + KMIN JJ = NLP1 + J - KMIN DO 50 K = KMIN,KMAX SUM = SUM + A(I,KK)*B(K,JJ) KK = KK + 1 JJ = JJ - 1 50 CONTINUE C(I,JC) = SUM 51 CONTINUE 52 CONTINUE C C FIND THE LAST NONZERO UPPER DIAGONAL C 100 JC = JC + 1 MCU = MIN0(L - 1,MU + NU) IF (MCU .EQ. 0) GO TO 130 C MAXD = MCU DO 121 NDIAG = 1,MAXD JMI = MAXD + 1 - NDIAG IMAX = MIN0(M,L - JMI,NPML,NPNU - JMI) DO 111 I = 1,IMAX J = I + JMI SUM = 0.D0 KMIN = MAX0(1,I - ML,J - NU) KMAX = MIN0(N,I + MU,J + NL) KK = MLP1 - I + KMIN JJ = NLP1 + J - KMIN DO 110 K = KMIN,KMAX SUM = SUM + A(I,KK)*B(K,JJ) KK = KK + 1 JJ = JJ - 1 110 CONTINUE C(I,JC) = SUM 111 CONTINUE C DO 120 I = 1,IMAX IF (C(I,JC) .NE. 0.D0) GO TO 130 120 CONTINUE MCU = MCU - 1 121 CONTINUE C 130 LAST = MCL + MCU + 1 IF (LAST .GT. NC) GO TO 200 IF (MCU .EQ. 0) GO TO 140 DO 131 I = 1,IMAX C(I,LAST) = C(I,JC) C(I,JC) = 0.D0 131 CONTINUE C C COMPUTE THE MAIN DIAGONAL AND THE REMAINING UPPER DIAGONALS C 140 MAXD = MAX0(1,MCU) DO 143 NDIAG = 1,MAXD JMI = NDIAG - 1 IMAX = MIN0(M,L - JMI,NPML,NPNU - JMI) DO 142 I = 1,IMAX J = I + JMI SUM = 0.D0 KMIN = MAX0(1,I - ML,J - NU) KMAX = MIN0(N,I + MU,J + NL) KK = MLP1 - I + KMIN JJ = NLP1 + J - KMIN DO 141 K = KMIN,KMAX SUM = SUM + A(I,KK)*B(K,JJ) KK = KK + 1 JJ = JJ - 1 141 CONTINUE C(I,JC) = SUM 142 CONTINUE JC = JC + 1 143 CONTINUE RETURN C C ERROR RETURN C 200 IERR = LAST RETURN END SUBROUTINE CBPROD (M, N, L, A, KA, ML, MU, B, KB, NL, NU, * C, KC, NC, MCL, MCU, IERR) C----------------------------------------------------------------------- C MULTIPLICATION OF COMPLEX BANDED MATRICES C----------------------------------------------------------------------- COMPLEX A(KA,*), B(KB,*), C(KC,NC) COMPLEX SUM C IERR = 0 DO 11 J = 1,NC DO 10 I = 1,M 10 C(I,J) = (0.0,0.0) 11 CONTINUE C MLP1 = ML + 1 NLP1 = NL + 1 NPML = N + ML NPNU = N + NU MCL = MIN0(M - 1,ML + NL) JC = 0 IF (MCL .EQ. 0) GO TO 100 C C FIND THE FIRST NONZERO LOWER DIAGONAL C MAXD = MCL DO 31 NDIAG = 1,MAXD IMJ = MAXD + 1 - NDIAG JMAX = MIN0(L,M - IMJ,NPML - IMJ,NPNU) DO 21 J = 1,JMAX I = J + IMJ SUM = (0.0,0.0) KMIN = MAX0(1,I - ML,J - NU) KMAX = MIN0(N,I + MU,J + NL) KK = MLP1 - I + KMIN JJ = NLP1 + J - KMIN DO 20 K = KMIN,KMAX SUM = SUM + A(I,KK)*B(K,JJ) KK = KK + 1 JJ = JJ - 1 20 CONTINUE C(I,1) = SUM 21 CONTINUE C DO 30 J = 1,JMAX I = J + IMJ IF (C(I,1) .NE. (0.0,0.0)) GO TO 40 30 CONTINUE MCL = MCL - 1 31 CONTINUE GO TO 100 C 40 IF (MCL .GE. NC) GO TO 100 JC = 1 IF (MCL .EQ. 1) GO TO 100 C C COMPUTE THE REMAINING LOWER DIAGONALS C MIND = NDIAG + 1 DO 52 NDIAG = MIND,MAXD JC = JC + 1 IMJ = MAXD + 1 - NDIAG JMAX = MIN0(L,M - IMJ,NPML - IMJ,NPNU) DO 51 J = 1,JMAX I = J + IMJ SUM = (0.0,0.0) KMIN = MAX0(1,I - ML,J - NU) KMAX = MIN0(N,I + MU,J + NL) KK = MLP1 - I + KMIN JJ = NLP1 + J - KMIN DO 50 K = KMIN,KMAX SUM = SUM + A(I,KK)*B(K,JJ) KK = KK + 1 JJ = JJ - 1 50 CONTINUE C(I,JC) = SUM 51 CONTINUE 52 CONTINUE C C FIND THE LAST NONZERO UPPER DIAGONAL C 100 JC = JC + 1 MCU = MIN0(L - 1,MU + NU) IF (MCU .EQ. 0) GO TO 130 C MAXD = MCU DO 121 NDIAG = 1,MAXD JMI = MAXD + 1 - NDIAG IMAX = MIN0(M,L - JMI,NPML,NPNU - JMI) DO 111 I = 1,IMAX J = I + JMI SUM = (0.0,0.0) KMIN = MAX0(1,I - ML,J - NU) KMAX = MIN0(N,I + MU,J + NL) KK = MLP1 - I + KMIN JJ = NLP1 + J - KMIN DO 110 K = KMIN,KMAX SUM = SUM + A(I,KK)*B(K,JJ) KK = KK + 1 JJ = JJ - 1 110 CONTINUE C(I,JC) = SUM 111 CONTINUE C DO 120 I = 1,IMAX IF (C(I,JC) .NE. (0.0,0.0)) GO TO 130 120 CONTINUE MCU = MCU - 1 121 CONTINUE C 130 LAST = MCL + MCU + 1 IF (LAST .GT. NC) GO TO 200 IF (MCU .EQ. 0) GO TO 140 DO 131 I = 1,IMAX C(I,LAST) = C(I,JC) C(I,JC) = (0.0,0.0) 131 CONTINUE C C COMPUTE THE MAIN DIAGONAL AND THE REMAINING UPPER DIAGONALS C 140 MAXD = MAX0(1,MCU) DO 143 NDIAG = 1,MAXD JMI = NDIAG - 1 IMAX = MIN0(M,L - JMI,NPML,NPNU - JMI) DO 142 I = 1,IMAX J = I + JMI SUM = (0.0,0.0) KMIN = MAX0(1,I - ML,J - NU) KMAX = MIN0(N,I + MU,J + NL) KK = MLP1 - I + KMIN JJ = NLP1 + J - KMIN DO 141 K = KMIN,KMAX SUM = SUM + A(I,KK)*B(K,JJ) KK = KK + 1 JJ = JJ - 1 141 CONTINUE C(I,JC) = SUM 142 CONTINUE JC = JC + 1 143 CONTINUE RETURN C C ERROR RETURN C 200 IERR = LAST RETURN END SUBROUTINE BVPRD (M,N,A,KA,ML,MU,X,Y) C----------------------------------------------------------------------- C PRODUCT OF A REAL BANDED MATRIX AND A REAL VECTOR C----------------------------------------------------------------------- REAL A(KA,*), X(N), Y(M) C C COMPUTE THE FIRST ML COMPONENTS C MLP1 = ML + 1 IF (ML .EQ. 0) GO TO 20 JMIN = MLP1 DO 11 I = 1,ML KMAX = MIN0(N,I + MU) KK = JMIN SUM = 0.0 DO 10 K = 1,KMAX SUM = SUM + A(I,KK)*X(K) KK = KK + 1 10 CONTINUE Y(I) = SUM JMIN = JMIN - 1 11 CONTINUE C C COMPUTE THE REMAINING NONZERO COMPONENTS C 20 IMAX = MIN0(M,N + ML) DO 22 I = MLP1,IMAX KMIN = I - ML KMAX = MIN0(N,I + MU) KK = 1 SUM = 0.0 DO 21 K = KMIN,KMAX SUM = SUM + A(I,KK)*X(K) KK = KK + 1 21 CONTINUE Y(I) = SUM 22 CONTINUE C C STORE ZEROS IN THE FINAL M-IMAX COMPONENTS C IF (IMAX .EQ. M) RETURN IMIN = IMAX + 1 DO 30 I = IMIN,M Y(I) = 0.0 30 CONTINUE RETURN END SUBROUTINE BVPRD1 (M,N,A,KA,ML,MU,X,Y) C----------------------------------------------------------------------- C SETTING Y = A*X + Y WHERE A IS A REAL BANDED MATRIX C AND X,Y ARE REAL VECTORS C----------------------------------------------------------------------- REAL A(KA,*), X(N), Y(M) C C COMPUTE THE FIRST ML COMPONENTS C MLP1 = ML + 1 IF (ML .EQ. 0) GO TO 20 JMIN = MLP1 DO 11 I = 1,ML KMAX = MIN0(N,I + MU) KK = JMIN SUM = Y(I) DO 10 K = 1,KMAX SUM = SUM + A(I,KK)*X(K) KK = KK + 1 10 CONTINUE Y(I) = SUM JMIN = JMIN - 1 11 CONTINUE C C COMPUTE THE REMAINING COMPONENTS C 20 IMAX = MIN0(M,N + ML) DO 22 I = MLP1,IMAX KMIN = I - ML KMAX = MIN0(N,I + MU) KK = 1 SUM = Y(I) DO 21 K = KMIN,KMAX SUM = SUM + A(I,KK)*X(K) KK = KK + 1 21 CONTINUE Y(I) = SUM 22 CONTINUE RETURN END SUBROUTINE DBVPD (M,N,A,KA,ML,MU,X,Y) C----------------------------------------------------------------------- C PRODUCT OF A DOUBLE PRECISION BANDED MATRIX C AND A DOUBLE PRECISION VECTOR C----------------------------------------------------------------------- DOUBLE PRECISION A(KA,*), X(N), Y(M) DOUBLE PRECISION SUM C C COMPUTE THE FIRST ML COMPONENTS C MLP1 = ML + 1 IF (ML .EQ. 0) GO TO 20 JMIN = MLP1 DO 11 I = 1,ML KMAX = MIN0(N,I + MU) KK = JMIN SUM = 0.D0 DO 10 K = 1,KMAX SUM = SUM + A(I,KK)*X(K) KK = KK + 1 10 CONTINUE Y(I) = SUM JMIN = JMIN - 1 11 CONTINUE C C COMPUTE THE REMAINING NONZERO COMPONENTS C 20 IMAX = MIN0(M,N + ML) DO 22 I = MLP1,IMAX KMIN = I - ML KMAX = MIN0(N,I + MU) KK = 1 SUM = 0.D0 DO 21 K = KMIN,KMAX SUM = SUM + A(I,KK)*X(K) KK = KK + 1 21 CONTINUE Y(I) = SUM 22 CONTINUE C C STORE ZEROS IN THE FINAL M-IMAX COMPONENTS C IF (IMAX .EQ. M) RETURN IMIN = IMAX + 1 DO 30 I = IMIN,M Y(I) = 0.D0 30 CONTINUE RETURN END SUBROUTINE DBVPD1 (M,N,A,KA,ML,MU,X,Y) C----------------------------------------------------------------------- C SETTING Y = A*X + Y WHERE A IS A DOUBLE PRECISION C BANDED MATRIX AND X,Y ARE DOUBLE PRECISION VECTORS C----------------------------------------------------------------------- DOUBLE PRECISION A(KA,*), X(N), Y(M) DOUBLE PRECISION SUM C C COMPUTE THE FIRST ML COMPONENTS C MLP1 = ML + 1 IF (ML .EQ. 0) GO TO 20 JMIN = MLP1 DO 11 I = 1,ML KMAX = MIN0(N,I + MU) KK = JMIN SUM = Y(I) DO 10 K = 1,KMAX SUM = SUM + A(I,KK)*X(K) KK = KK + 1 10 CONTINUE Y(I) = SUM JMIN = JMIN - 1 11 CONTINUE C C COMPUTE THE REMAINING COMPONENTS C 20 IMAX = MIN0(M,N + ML) DO 22 I = MLP1,IMAX KMIN = I - ML KMAX = MIN0(N,I + MU) KK = 1 SUM = Y(I) DO 21 K = KMIN,KMAX SUM = SUM + A(I,KK)*X(K) KK = KK + 1 21 CONTINUE Y(I) = SUM 22 CONTINUE RETURN END SUBROUTINE CBVPD (M,N,A,KA,ML,MU,X,Y) C----------------------------------------------------------------------- C PRODUCT OF A COMPLEX BANDED MATRIX AND A COMPLEX VECTOR C----------------------------------------------------------------------- COMPLEX A(KA,*), X(N), Y(M) COMPLEX SUM C C COMPUTE THE FIRST ML COMPONENTS C MLP1 = ML + 1 IF (ML .EQ. 0) GO TO 20 JMIN = MLP1 DO 11 I = 1,ML KMAX = MIN0(N,I + MU) KK = JMIN SUM = (0.0,0.0) DO 10 K = 1,KMAX SUM = SUM + A(I,KK)*X(K) KK = KK + 1 10 CONTINUE Y(I) = SUM JMIN = JMIN - 1 11 CONTINUE C C COMPUTE THE REMAINING NONZERO COMPONENTS C 20 IMAX = MIN0(M,N + ML) DO 22 I = MLP1,IMAX KMIN = I - ML KMAX = MIN0(N,I + MU) KK = 1 SUM = (0.0,0.0) DO 21 K = KMIN,KMAX SUM = SUM + A(I,KK)*X(K) KK = KK + 1 21 CONTINUE Y(I) = SUM 22 CONTINUE C C STORE ZEROS IN THE FINAL M-IMAX COMPONENTS C IF (IMAX .EQ. M) RETURN IMIN = IMAX + 1 DO 30 I = IMIN,M Y(I) = (0.0,0.0) 30 CONTINUE RETURN END SUBROUTINE CBVPD1 (M,N,A,KA,ML,MU,X,Y) C----------------------------------------------------------------------- C SETTING Y = A*X + Y WHERE A IS A COMPLEX BANDED MATRIX C AND X,Y ARE COMPLEX VECTORS C----------------------------------------------------------------------- COMPLEX A(KA,*), X(N), Y(M) COMPLEX SUM C C COMPUTE THE FIRST ML COMPONENTS C MLP1 = ML + 1 IF (ML .EQ. 0) GO TO 20 JMIN = MLP1 DO 11 I = 1,ML KMAX = MIN0(N,I + MU) KK = JMIN SUM = Y(I) DO 10 K = 1,KMAX SUM = SUM + A(I,KK)*X(K) KK = KK + 1 10 CONTINUE Y(I) = SUM JMIN = JMIN - 1 11 CONTINUE C C COMPUTE THE REMAINING COMPONENTS C 20 IMAX = MIN0(M,N + ML) DO 22 I = MLP1,IMAX KMIN = I - ML KMAX = MIN0(N,I + MU) KK = 1 SUM = Y(I) DO 21 K = KMIN,KMAX SUM = SUM + A(I,KK)*X(K) KK = KK + 1 21 CONTINUE Y(I) = SUM 22 CONTINUE RETURN END SUBROUTINE BTPRD (M,N,A,KA,ML,MU,X,Y) C----------------------------------------------------------------------- C PRODUCT OF A REAL VECTOR AND A REAL BANDED MATRIX C----------------------------------------------------------------------- REAL A(KA,*), X(M), Y(N) C C COMPUTE THE FIRST MU COMPONENTS C IF (MU .EQ. 0) GO TO 20 DO 11 J = 1,MU JJ = ML + J KMAX = MIN0(M,JJ) SUM = 0.0 DO 10 K = 1,KMAX SUM = SUM + A(K,JJ)*X(K) JJ = JJ - 1 10 CONTINUE Y(J) = SUM 11 CONTINUE C C COMPUTE THE REMAINING NONZERO COMPONENTS C 20 NUM = ML + MU + 1 JMIN = MU + 1 JMAX = MIN0(N,M + MU) DO 22 J = JMIN,JMAX KMIN = J - MU KMAX = MIN0(M,J + ML) JJ = NUM SUM = 0.0 DO 21 K = KMIN,KMAX SUM = SUM + A(K,JJ)*X(K) JJ = JJ - 1 21 CONTINUE Y(J) = SUM 22 CONTINUE C C STORE ZEROS IN THE FINAL N-JMAX COMPONENTS C IF (JMAX .EQ. N) RETURN JMIN = JMAX + 1 DO 30 J = JMIN,N Y(J) = 0.0 30 CONTINUE RETURN END SUBROUTINE BTPRD1 (M,N,A,KA,ML,MU,X,Y) C----------------------------------------------------------------------- C SETTING Y = X*A + Y WHERE A IS A REAL BANDED MATRIX C AND X,Y ARE REAL VECTORS C----------------------------------------------------------------------- REAL A(KA,*), X(M), Y(N) C C COMPUTE THE FIRST MU COMPONENTS C IF (MU .EQ. 0) GO TO 20 DO 11 J = 1,MU JJ = ML + J KMAX = MIN0(M,JJ) SUM = Y(J) DO 10 K = 1,KMAX SUM = SUM + A(K,JJ)*X(K) JJ = JJ - 1 10 CONTINUE Y(J) = SUM 11 CONTINUE C C COMPUTE THE REMAINING COMPONENTS C 20 NUM = ML + MU + 1 JMIN = MU + 1 JMAX = MIN0(N,M + MU) DO 22 J = JMIN,JMAX KMIN = J - MU KMAX = MIN0(M,J + ML) JJ = NUM SUM = Y(J) DO 21 K = KMIN,KMAX SUM = SUM + A(K,JJ)*X(K) JJ = JJ - 1 21 CONTINUE Y(J) = SUM 22 CONTINUE RETURN END SUBROUTINE DBTPD (M,N,A,KA,ML,MU,X,Y) C----------------------------------------------------------------------- C PRODUCT OF A DOUBLE PRECISION VECTOR AND C A DOUBLE PRECISION BANDED MATRIX C----------------------------------------------------------------------- DOUBLE PRECISION A(KA,*), X(M), Y(N) DOUBLE PRECISION SUM C C COMPUTE THE FIRST MU COMPONENTS C IF (MU .EQ. 0) GO TO 20 DO 11 J = 1,MU JJ = ML + J KMAX = MIN0(M,JJ) SUM = 0.D0 DO 10 K = 1,KMAX SUM = SUM + A(K,JJ)*X(K) JJ = JJ - 1 10 CONTINUE Y(J) = SUM 11 CONTINUE C C COMPUTE THE REMAINING NONZERO COMPONENTS C 20 NUM = ML + MU + 1 JMIN = MU + 1 JMAX = MIN0(N,M + MU) DO 22 J = JMIN,JMAX KMIN = J - MU KMAX = MIN0(M,J + ML) JJ = NUM SUM = 0.D0 DO 21 K = KMIN,KMAX SUM = SUM + A(K,JJ)*X(K) JJ = JJ - 1 21 CONTINUE Y(J) = SUM 22 CONTINUE C C STORE ZEROS IN THE FINAL N-JMAX COMPONENTS C IF (JMAX .EQ. N) RETURN JMIN = JMAX + 1 DO 30 J = JMIN,N Y(J) = 0.D0 30 CONTINUE RETURN END SUBROUTINE DBTPD1 (M,N,A,KA,ML,MU,X,Y) C----------------------------------------------------------------------- C SETTING Y = X*A + Y WHERE A IS A DOUBLE PRECISION C BANDED MATRIX AND X,Y ARE DOUBLE PRECISION VECTORS C----------------------------------------------------------------------- DOUBLE PRECISION A(KA,*), X(M), Y(N) DOUBLE PRECISION SUM C C COMPUTE THE FIRST MU COMPONENTS C IF (MU .EQ. 0) GO TO 20 DO 11 J = 1,MU JJ = ML + J KMAX = MIN0(M,JJ) SUM = Y(J) DO 10 K = 1,KMAX SUM = SUM + A(K,JJ)*X(K) JJ = JJ - 1 10 CONTINUE Y(J) = SUM 11 CONTINUE C C COMPUTE THE REMAINING COMPONENTS C 20 NUM = ML + MU + 1 JMIN = MU + 1 JMAX = MIN0(N,M + MU) DO 22 J = JMIN,JMAX KMIN = J - MU KMAX = MIN0(M,J + ML) JJ = NUM SUM = Y(J) DO 21 K = KMIN,KMAX SUM = SUM + A(K,JJ)*X(K) JJ = JJ - 1 21 CONTINUE Y(J) = SUM 22 CONTINUE RETURN END SUBROUTINE CBTPD (M,N,A,KA,ML,MU,X,Y) C----------------------------------------------------------------------- C PRODUCT OF A COMPLEX VECTOR AND A COMPLEX BANDED MATRIX C----------------------------------------------------------------------- COMPLEX A(KA,*), X(M), Y(N) COMPLEX SUM C C COMPUTE THE FIRST MU COMPONENTS C IF (MU .EQ. 0) GO TO 20 DO 11 J = 1,MU JJ = ML + J KMAX = MIN0(M,JJ) SUM = (0.0,0.0) DO 10 K = 1,KMAX SUM = SUM + A(K,JJ)*X(K) JJ = JJ - 1 10 CONTINUE Y(J) = SUM 11 CONTINUE C C COMPUTE THE REMAINING NONZERO COMPONENTS C 20 NUM = ML + MU + 1 JMIN = MU + 1 JMAX = MIN0(N,M + MU) DO 22 J = JMIN,JMAX KMIN = J - MU KMAX = MIN0(M,J + ML) JJ = NUM SUM = (0.0,0.0) DO 21 K = KMIN,KMAX SUM = SUM + A(K,JJ)*X(K) JJ = JJ - 1 21 CONTINUE Y(J) = SUM 22 CONTINUE C C STORE ZEROS IN THE FINAL N-JMAX COMPONENTS C IF (JMAX .EQ. N) RETURN JMIN = JMAX + 1 DO 30 J = JMIN,N Y(J) = (0.0,0.0) 30 CONTINUE RETURN END SUBROUTINE CBTPD1 (M,N,A,KA,ML,MU,X,Y) C----------------------------------------------------------------------- C SETTING Y = X*A + Y WHERE A IS A COMPLEX BANDED MATRIX C AND X,Y ARE COMPLEX VECTORS C----------------------------------------------------------------------- COMPLEX A(KA,*), X(M), Y(N) COMPLEX SUM C C COMPUTE THE FIRST MU COMPONENTS C IF (MU .EQ. 0) GO TO 20 DO 11 J = 1,MU JJ = ML + J KMAX = MIN0(M,JJ) SUM = Y(J) DO 10 K = 1,KMAX SUM = SUM + A(K,JJ)*X(K) JJ = JJ - 1 10 CONTINUE Y(J) = SUM 11 CONTINUE C C COMPUTE THE REMAINING COMPONENTS C 20 NUM = ML + MU + 1 JMIN = MU + 1 JMAX = MIN0(N,M + MU) DO 22 J = JMIN,JMAX KMIN = J - MU KMAX = MIN0(M,J + ML) JJ = NUM SUM = Y(J) DO 21 K = KMIN,KMAX SUM = SUM + A(K,JJ)*X(K) JJ = JJ - 1 21 CONTINUE Y(J) = SUM 22 CONTINUE RETURN END REAL FUNCTION BNRM (A, KA, M, N, ML, MU) C----------------------------------------------------------------------- C COMPUTATION OF THE L-INFINITY NORM OF A C REAL BANDED MATRIX A C----------------------------------------------------------------------- REAL A(KA,*) C NUM = ML + MU + 1 BNRM = 0.0 DO 20 I = 1,M SUM = 0.0 DO 10 J = 1,NUM SUM = SUM + ABS(A(I,J)) 10 CONTINUE BNRM = AMAX1(BNRM, SUM) 20 CONTINUE RETURN END REAL FUNCTION B1NRM (A, KA, M, N, ML, MU) C----------------------------------------------------------------------- C COMPUTATION OF THE L1 NORM OF A BANDED MATRIX A C----------------------------------------------------------------------- REAL A(*) C INCR = KA - 1 B1NRM = 0.0 C C GO DOWN THE FIRST COLUMN OF A C IMIN = ML + 1 IMAX = MIN0(M, IMIN + MU) DO 10 I = IMIN,IMAX B1NRM = AMAX1(B1NRM, SASUM(I,A(I),INCR)) 10 CONTINUE I = IMAX J = I - ML NUM = I IF (J .EQ. N) RETURN IF (I .EQ. M) GO TO 30 C IMIN = I + 1 IMAX = MIN0(M, ML + N) DO 20 I = IMIN,IMAX B1NRM = AMAX1(B1NRM, SASUM(NUM,A(I),INCR)) 20 CONTINUE I = IMAX J = I - ML GO TO 50 C C PROCEED ALONG THE LAST ROW OF A C 30 JMAX = MU + 1 IF (J .EQ. JMAX) GO TO 50 JMIN = J + 1 DO 40 J = JMIN,JMAX I = I + KA B1NRM = AMAX1(B1NRM, SASUM(NUM,A(I),INCR)) 40 CONTINUE J = JMAX C 50 IF (J .EQ. N .OR. NUM .EQ. 1) RETURN I = I + KA J = J + 1 NUM = NUM - 1 B1NRM = AMAX1(B1NRM, SASUM(NUM,A(I),INCR)) GO TO 50 END DOUBLE PRECISION FUNCTION DBNRM (A, KA, M, N, ML, MU) C----------------------------------------------------------------------- C COMPUTATION OF THE L-INFINITY NORM OF A C DOUBLE PRECISION BANDED MATRIX A C----------------------------------------------------------------------- DOUBLE PRECISION A(KA,*) DOUBLE PRECISION SUM C NUM = ML + MU + 1 DBNRM = 0.D0 DO 20 I = 1,M SUM = 0.D0 DO 10 J = 1,NUM SUM = SUM + DABS(A(I,J)) 10 CONTINUE DBNRM = DMAX1(DBNRM, SUM) 20 CONTINUE RETURN END DOUBLE PRECISION FUNCTION DB1NRM (A, KA, M, N, ML, MU) C----------------------------------------------------------------------- C COMPUTATION OF THE L1 NORM OF A DOUBLE PRECISION C BANDED MATRIX A C----------------------------------------------------------------------- DOUBLE PRECISION A(*) DOUBLE PRECISION DASUM C INCR = KA - 1 DB1NRM = 0.D0 C C GO DOWN THE FIRST COLUMN OF A C IMIN = ML + 1 IMAX = MIN0(M, IMIN + MU) DO 10 I = IMIN,IMAX DB1NRM = DMAX1(DB1NRM, DASUM(I,A(I),INCR)) 10 CONTINUE I = IMAX J = I - ML NUM = I IF (J .EQ. N) RETURN IF (I .EQ. M) GO TO 30 C IMIN = I + 1 IMAX = MIN0(M, ML + N) DO 20 I = IMIN,IMAX DB1NRM = DMAX1(DB1NRM, DASUM(NUM,A(I),INCR)) 20 CONTINUE I = IMAX J = I - ML GO TO 50 C C PROCEED ALONG THE LAST ROW OF A C 30 JMAX = MU + 1 IF (J .EQ. JMAX) GO TO 50 JMIN = J + 1 DO 40 J = JMIN,JMAX I = I + KA DB1NRM = DMAX1(DB1NRM, DASUM(NUM,A(I),INCR)) 40 CONTINUE J = JMAX C 50 IF (J .EQ. N .OR. NUM .EQ. 1) RETURN I = I + KA J = J + 1 NUM = NUM - 1 DB1NRM = DMAX1(DB1NRM, DASUM(NUM,A(I),INCR)) GO TO 50 END SUBROUTINE BSLV(M0,A,KA,N,ML,MU,B,IWK,IERR) C ---------------------------------------------------------------------- C BSLV EMPLOYS GAUSS ELIMINATION WITH ROW INTERCHANGES TO SOLVE C THE NXN BANDED LINEAR SYSTEM AX = B. THE ARGUMENT M0 SPECIFIES C IF BSLV IS BEING CALLED FOR THE FIRST TIME, OR IF IT IS BEING C RECALLED WHERE A IS THE SAME MATRIX BUT B HAS BEEN MODIFIED. C ON AN INITIAL CALL TO THE ROUTINE (WHEN M0=0) AN LU DECOMPO- C SITION OF A IS OBTAINED AND THEN THE EQUATIONS ARE SOLVED. C ON SUBSEQUENT CALLS (WHEN M0.NE.0) THE EQUATIONS ARE SOLVED C USING THE DECOMPOSITION OBTAINED ON THE INITIAL CALL TO BSLV. C C C INPUT ARGUMENTS WHEN M0=0 --- C C A,KA 2-DIMENSIONAL ARRAY OF DIMENSION (KA,M) WHERE C KA.GE.N AND M.GE.2*ML+MU+1. THE FIRST ML+MU+1 C COLUMNS CONTAIN THE MATRIX A IN BANDED FORM. C C N NUMBER OF EQUATIONS AND UNKNOWNS. C C ML NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL. C C MU NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL. C C B ARRAY OF N ENTRIES CONTAINING THE RIGHT HAND C SIDE DATA. C C C OUTPUT ARGUMENTS WHEN M0=0 --- C C A AN UPPER TIANGULAR MATRIX IN BAND STORAGE AND C THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT. C C B THE SOLUTION OF THE EQUATIONS. C C IWK ARRAY OF LENGTH N CONTAINING THE PIVOT INDICES. C C IERR INTEGER SPECIFYING THE STATUS OF THE RESULTS. C IERR=0 IF THE SOLUTION OF AX = B IS OBTAINED. C OTHERWISE IERR.NE.0. C C C AFTER AN INITIAL CALL TO BSLV, THE ROUTINE MAY BE RECALLED C WITH M0.NE.0 FOR A NEW B. WHEN M0.NE.0 IT IS ASSUMED THAT C A,KA,N,ML,MU,IWK HAVE NOT BEEN MODIFIED. BSLV RETRIEVES THE C LU DECOMPOSITION WHICH WAS OBTAINED ON THE INITIAL CALL TO C BSLV AND SOLVES THE NEW EQUATIONS AX = B. IN THIS CASE IERR C IS NOT REFERENCED. C ---------------------------------------------------------------------- REAL A(KA,*),B(N) INTEGER IWK(N) IF (M0 .NE. 0) GO TO 10 C C ERROR CHECKING C IF (N .LE. 0 .OR. N .GT. KA) GO TO 100 IF (ML .LT. 0 .OR. ML .GE. N) GO TO 110 IF (MU .LT. 0 .OR. MU .GE. N) GO TO 120 C C OBTAIN AN LU DECOMPOSITION OF A C CALL SNBFA(A,KA,N,ML,MU,IWK,IERR) IF (IERR .NE. 0) RETURN C C SOLVE THE SYSTEM OF EQUATIONS C 10 CALL SNBSL(A,KA,N,ML,MU,IWK,B,0) RETURN C C ERROR RETURN C 100 IERR = -1 RETURN 110 IERR = -2 RETURN 120 IERR = -3 RETURN END SUBROUTINE BSLV1(M0,A,KA,N,ML,MU,B,IWK,IERR) C ---------------------------------------------------------------------- C BSLV1 EMPLOYS GAUSS ELIMINATION WITH ROW INTERCHANGES TO SOLVE C THE NXN BANDED LINEAR SYSTEM XA = B. THE ARGUMENT M0 SPECIFIES C IF BSLV1 IS BEING CALLED FOR THE FIRST TIME, OR IF IT IS BEING C RECALLED WHERE A IS THE SAME MATRIX BUT B HAS BEEN MODIFIED. C ON AN INITIAL CALL TO THE ROUTINE (WHEN M0=0) AN LU DECOMPO- C SITION OF A IS OBTAINED AND THEN THE EQUATIONS ARE SOLVED. C ON SUBSEQUENT CALLS (WHEN M0.NE.0) THE EQUATIONS ARE SOLVED C USING THE DECOMPOSITION OBTAINED ON THE INITIAL CALL TO BSLV1. C C C INPUT ARGUMENTS WHEN M0=0 --- C C A,KA 2-DIMENSIONAL ARRAY OF DIMENSION (KA,M) WHERE C KA.GE.N AND M.GE.2*ML+MU+1. THE FIRST ML+MU+1 C COLUMNS CONTAIN THE MATRIX A IN BANDED FORM. C C N NUMBER OF EQUATIONS AND UNKNOWNS. C C ML NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL. C C MU NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL. C C B ARRAY OF N ENTRIES CONTAINING THE RIGHT HAND C SIDE DATA. C C C OUTPUT ARGUMENTS WHEN M0=0 --- C C A AN UPPER TIANGULAR MATRIX IN BAND STORAGE AND C THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT. C C B THE SOLUTION OF THE EQUATIONS. C C IWK ARRAY OF LENGTH N CONTAINING THE PIVOT INDICES. C C IERR INTEGER SPECIFYING THE STATUS OF THE RESULTS. C IERR=0 IF THE SOLUTION OF XA = B IS OBTAINED. C OTHERWISE IERR.NE.0. C C C AFTER AN INITIAL CALL TO BSLV1, THE ROUTINE MAY BE RECALLED C WITH M0.NE.0 FOR A NEW B. WHEN M0.NE.0 IT IS ASSUMED THAT C A,KA,N,ML,MU,IWK HAVE NOT BEEN MODIFIED. BSLV RETRIEVES THE C LU DECOMPOSITION WHICH WAS OBTAINED ON THE INITIAL CALL TO C BSLV1 AND SOLVES THE NEW EQUATIONS XA = B. IN THIS CASE IERR C IS NOT REFERENCED. C ---------------------------------------------------------------------- REAL A(KA,*),B(N) INTEGER IWK(N) IF (M0 .NE. 0) GO TO 10 C C ERROR CHECKING C IF (N .LE. 0 .OR. N .GT. KA) GO TO 100 IF (ML .LT. 0 .OR. ML .GE. N) GO TO 110 IF (MU .LT. 0 .OR. MU .GE. N) GO TO 120 C C OBTAIN AN LU DECOMPOSITION OF A C CALL SNBFA(A,KA,N,ML,MU,IWK,IERR) IF (IERR .NE. 0) RETURN C C SOLVE THE SYSTEM OF EQUATIONS C 10 CALL SNBSL(A,KA,N,ML,MU,IWK,B,1) RETURN C C ERROR RETURN C 100 IERR = -1 RETURN 110 IERR = -2 RETURN 120 IERR = -3 RETURN END SUBROUTINE SNBFA (A, LDA, N, ML, MU, IPVT, INFO) C ---------------------------------------------------------------------- C C SNBFA FACTORS A REAL BAND MATRIX BY ELIMINATION. C C -------- C ON ENTRY C C A REAL(LDA, NC) C CONTAINS THE MATRIX IN BAND STORAGE. THE ROWS C OF THE ORIGINAL MATRIX ARE STORED IN THE ROWS C OF A AND THE DIAGONALS OF THE ORIGINAL MATRIX C ARE STORED IN COLUMNS 1 THROUGH ML+MU+1 OF A. C NC MUST BE .GE. 2*ML+MU+1 . C SEE THE COMMENTS BELOW FOR DETAILS. C C LDA INTEGER C THE LEADING DIMENSION OF THE ARRAY A. IT IS C ASSUMED THAT LDA .GE. N. C C N INTEGER C THE ORDER OF THE ORIGINAL MATRIX. C C ML INTEGER C NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL. C 0 .LE. ML .LT. N . C C MU INTEGER C NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL. C 0 .LE. MU .LT. N . C MORE EFFICIENT IF ML .LE. MU . C C ON RETURN C C A AN UPPER TRIANGULAR MATRIX IN BAND STORAGE C AND THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT. C THE FACTORIZATION CAN BE WRITTEN A = L*U WHERE C L IS A PRODUCT OF PERMUTATION AND UNIT LOWER C TRIANGULAR MATRICES AND U IS UPPER TRIANGULAR. C C IPVT INTEGER(N) C AN INTEGER VECTOR OF PIVOT INDICES. C C INFO INTEGER C =0 NORMAL VALUE C =K IF U(K,K) .EQ. 0. THIS IS NOT AN ERROR C CONDITION FOR THIS SUBROUTINE, BUT IT DOES C INDICATE THAT SNBSL WILL DIVIDE BY ZERO IF C IT IS CALLED. C C BAND STORAGE C C IF A0 IS THE MATRIX THEN THE FOLLOWING CODE WILL STORE C A0 IN BAND FORM. C C ML = (BAND WIDTH BELOW THE DIAGONAL) C MU = (BAND WIDTH ABOVE THE DIAGONAL) C DO 20 I = 1, N C J1 = MAX0(1, I-ML) C J2 = MIN0(N, I+MU) C DO 10 J = J1, J2 C K = J - I + ML + 1 C A(I,K) = A0(I,J) C 10 CONTINUE C 20 CONTINUE C C THIS USES COLUMNS 1 THROUGH ML + MU + 1 OF A. C FURTHERMORE, ML ADDITIONAL COLUMNS ARE NEEDED IN C A (STARTING WITH COLUMN ML+MU+2) FOR ELEMENTS C GENERATED DURING THE TRIANGULARIZATION. THE TOTAL C NUMBER OF COLUMNS NEEDED IN A IS 2*ML+MU+1 . C C EXAMPLE.. IF THE ORIGINAL MATRIX IS C C 11 12 13 0 0 0 C 21 22 23 24 0 0 C 0 32 33 34 35 0 C 0 0 43 44 45 46 C 0 0 0 54 55 56 C 0 0 0 0 65 66 C C THEN N = 6, ML = 1, MU = 2, LDA .GE. 6 AND A SHOULD CONTAIN C C 11 12 13 + , + = USED FOR PIVOTING C 21 22 23 24 + C 32 33 34 35 + C 43 44 45 46 + C 54 55 56 + + C 65 66 + + + C C WRITTEN BY E.A.VOORHEES, LOS ALAMOS SCIENTIFIC LABORATORY. C MODIFIED BY A.H.MORRIS, NAVAL SURFACE WEAPONS CENTER. C C SUBROUTINES AND FUNCTIONS C MIN0,ISAMAX,SAXPY,SSCAL,SSWAP C ---------------------------------------------------------------------- INTEGER LDA,N,ML,MU,INFO REAL A(LDA,*) INTEGER IPVT(N) REAL T C INFO = 0 IF (ML .EQ. 0) GO TO 100 M = ML + MU + 1 C C SET FILL-IN COLUMNS TO ZERO C DO 11 J = 1,ML JJ = M + J DO 10 I = 1,N A(I,JJ) = 0.0 10 CONTINUE 11 CONTINUE C C GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING C ML1 = ML + 1 MB = ML + MU N1 = N - 1 LDB = LDA - 1 DO 40 K = 1,N1 LM = MIN0(N-K,ML) LMK = LM + K LM1 = LM + 1 LM2 = ML1 - LM C C SEARCH FOR PIVOT INDEX C L = -ISAMAX(LM1, A(LMK,LM2), LDB) + LM1 + K IPVT(K) = L MP = MIN0(MB,N-K) C C SWAP ROWS IF NECESSARY C LL = ML1 + K - L IF (L .NE. K) CALL SSWAP(MP + 1, A(K,ML1), LDA, A(L,LL), LDA) C C SKIP COLUMN REDUCTION IF PIVOT IS ZERO C IF (A(K,ML1) .NE. 0.0) GO TO 20 INFO = K GO TO 40 C C COMPUTE MULTIPLIERS C 20 T = -1.0/A(K,ML1) CALL SSCAL(LM, T, A(LMK,LM2), LDB) C C ROW ELIMINATION WITH COLUMN INDEXING C DO 30 J = 1,MP JJ = ML1 + J J1 = LM2 + J CALL SAXPY(LM, A(K,JJ), A(LMK,LM2), LDB, A(LMK,J1), LDB) 30 CONTINUE 40 CONTINUE C IPVT(N) = N IF (A(N,ML1) .EQ. 0.0) INFO = N RETURN C C CASE WHEN ML = 0 C 100 DO 110 K = 1,N IPVT(K) = K IF (A(K,1) .EQ. 0.0) INFO = K 110 CONTINUE RETURN END SUBROUTINE SNBSL (A,LDA,N,ML,MU,IPVT,B,JOB) C ---------------------------------------------------------------------- C C SNBSL SOLVES THE REAL BAND SYSTEM A*X = B OR TRANS(A)*X = B C USING THE FACTORS COMPUTED BY SNBFA. C C ---------- C ON ENTRY C C A REAL(LDA, NC) C THE OUTPUT FROM SNBFA. C NC MUST BE .GE. 2*ML+MU+1 . C C LDA INTEGER C THE LEADING DIMENSION OF THE ARRAY A. C C N INTEGER C THE ORDER OF THE ORIGINAL MATRIX. C C ML INTEGER C NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL. C C MU INTEGER C NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL. C C IPVT INTEGER(N) C THE PIVOT VECTOR FROM SNBFA. C C B REAL(N) C THE RIGHT HAND SIDE VECTOR. C C JOB INTEGER C = 0 TO SOLVE A*X = B . C = NONZERO TO SOLVE TRANS(A)*X = B , WHERE C TRANS(A) IS THE TRANSPOSE. C C ON RETURN C C B THE SOLUTION VECTOR X . C C ERROR CONDITION C C A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A C ZERO ON THE DIAGONAL. TECHNICALLY THIS INDICATES SINGULARITY C BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER C SETTING OF LDA. IT WILL NOT OCCUR IF SNBFA AND SNBSL ARE C CALLED CORRECTLY AND SNBFA HAS SET INFO = 0. C C WRITTEN BY E.A. VOORHEES, LOS ALAMOS SCIENTIFIC LABORATORY. C MODIFIED BY A.H. MORRIS, NAVAL SURFACE WEAPONS CENTER. C C SUBROUTINES AND FUNCTIONS C SAXPY,SDOT C C FORTRAN MIN0 C ---------------------------------------------------------------------- INTEGER LDA,N,ML,MU,JOB REAL A(LDA,*),B(N) INTEGER IPVT(N) REAL SDOT,T INTEGER K,KB,KLM,L,LB,LDB,LM,M,MLM,NM1 C M = MU + ML + 1 IF (M .EQ. 1) GO TO 100 ML1 = ML + 1 ML2 = ML + 2 NM1 = N - 1 LDB = 1 - LDA IF (JOB .NE. 0) GO TO 50 C C JOB = 0 , SOLVE A * X = B C FIRST SOLVE L*Y = B C IF (ML .EQ. 0) GO TO 30 DO 20 K = 1,NM1 LM = MIN0(ML,N-K) L = IPVT(K) T = B(L) IF (L .EQ. K) GO TO 10 B(L) = B(K) B(K) = T 10 KLM = K + LM MLM = ML1 - LM CALL SAXPY(LM, T, A(KLM,MLM), LDB, B(K+1), 1) 20 CONTINUE C C NOW SOLVE U*X = Y C 30 K = N DO 40 KB = 2,N B(K) = B(K)/A(K,ML1) LM = MIN0(K,M) - 1 LB = K - LM T = -B(K) CALL SAXPY(LM, T, A(K-1,ML2), LDB, B(LB), 1) K = K - 1 40 CONTINUE B(1) = B(1)/A(1,ML1) RETURN C C JOB = NONZERO, SOLVE TRANS(A) * X = B C FIRST SOLVE TRANS(U)*Y = B C 50 B(1) = B(1)/A(1,ML1) DO 60 K = 2,N LM = MIN0(K,M) - 1 LB = K - LM T = SDOT(LM, A(K-1,ML2), LDB, B(LB), 1) B(K) = (B(K) - T)/A(K,ML1) 60 CONTINUE IF (ML .EQ. 0) RETURN C C NOW SOLVE TRANS(L)*X = Y C DO 70 KB = 1,NM1 K = N - KB LM = MIN0(ML,N-K) KLM = K + LM MLM = ML1 - LM B(K) = B(K) + SDOT(LM, A(KLM,MLM), LDB, B(K+1), 1) L = IPVT(K) IF (L .EQ. K) GO TO 70 T = B(L) B(L) = B(K) B(K) = T 70 CONTINUE RETURN C C CASE WHEN ML = 0 AND MU = 0 C 100 DO 110 K = 1,N 110 B(K) = B(K)/A(K,1) RETURN END SUBROUTINE DBSLV (M0,A,KA,N,ML,MU,B,IWK,IERR) C ---------------------------------------------------------------------- C DBSLV EMPLOYS GAUSS ELIMINATION WITH ROW INTERCHANGES TO SOLVE C THE NXN BANDED LINEAR SYSTEM AX = B. THE ARGUMENT M0 SPECIFIES C IF DBSLV IS BEING CALLED FOR THE FIRST TIME, OR IF IT IS BEING C RECALLED WHERE A IS THE SAME MATRIX BUT B HAS BEEN MODIFIED. C ON AN INITIAL CALL TO THE ROUTINE (WHEN M0=0) AN LU DECOMPO- C SITION OF A IS OBTAINED AND THEN THE EQUATIONS ARE SOLVED. C ON SUBSEQUENT CALLS (WHEN M0.NE.0) THE EQUATIONS ARE SOLVED C USING THE DECOMPOSITION OBTAINED ON THE INITIAL CALL TO DBSLV. C C C INPUT ARGUMENTS WHEN M0=0 --- C C A,KA 2-DIMENSIONAL ARRAY OF DIMENSION (KA,M) WHERE C KA.GE.N AND M.GE.2*ML+MU+1. THE FIRST ML+MU+1 C COLUMNS CONTAIN THE MATRIX A IN BANDED FORM. C C N NUMBER OF EQUATIONS AND UNKNOWNS. C C ML NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL. C C MU NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL. C C B ARRAY OF N ENTRIES CONTAINING THE RIGHT HAND C SIDE DATA. C C C OUTPUT ARGUMENTS WHEN M0=0 --- C C A AN UPPER TIANGULAR MATRIX IN BAND STORAGE AND C THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT. C C B THE SOLUTION OF THE EQUATIONS. C C IWK ARRAY OF LENGTH N CONTAINING THE PIVOT INDICES. C C IERR INTEGER SPECIFYING THE STATUS OF THE RESULTS. C IERR=0 IF THE SOLUTION OF AX = B IS OBTAINED. C OTHERWISE IERR.NE.0. C C C AFTER AN INITIAL CALL TO DBSLV, THE ROUTINE MAY BE RECALLED C WITH M0.NE.0 FOR A NEW B. WHEN M0.NE.0 IT IS ASSUMED THAT C A,KA,N,ML,MU,IWK HAVE NOT BEEN MODIFIED. DBSLV RETRIEVES THE C LU DECOMPOSITION WHICH WAS OBTAINED ON THE INITIAL CALL TO C DBSLV AND SOLVES THE NEW EQUATIONS AX = B. IN THIS CASE IERR C IS NOT REFERENCED. C ---------------------------------------------------------------------- DOUBLE PRECISION A(KA,*), B(N) INTEGER IWK(N) IF (M0 .NE. 0) GO TO 10 C C ERROR CHECKING C IF (N .LE. 0 .OR. N .GT. KA) GO TO 100 IF (ML .LT. 0 .OR. ML .GE. N) GO TO 110 IF (MU .LT. 0 .OR. MU .GE. N) GO TO 120 C C OBTAIN AN LU DECOMPOSITION OF A C CALL DBFA(A,KA,N,ML,MU,IWK,IERR) IF (IERR .NE. 0) RETURN C C SOLVE THE SYSTEM OF EQUATIONS C 10 CALL DBSL(A,KA,N,ML,MU,IWK,B,0) RETURN C C ERROR RETURN C 100 IERR = -1 RETURN 110 IERR = -2 RETURN 120 IERR = -3 RETURN END SUBROUTINE DBSLV1 (M0,A,KA,N,ML,MU,B,IWK,IERR) C ---------------------------------------------------------------------- C DBSLV1 EMPLOYS GAUSS ELIMINATION WITH ROW INTERCHANGES TO SOLVE C THE NXN BANDED LINEAR SYSTEM XA = B. THE ARGUMENT M0 SPECIFIES C IF DBSLV1 IS BEING CALLED FOR THE FIRST TIME, OR IF IT IS BEING C RECALLED WHERE A IS THE SAME MATRIX BUT B HAS BEEN MODIFIED. C ON AN INITIAL CALL TO THE ROUTINE (WHEN M0=0) AN LU DECOMPO- C SITION OF A IS OBTAINED AND THEN THE EQUATIONS ARE SOLVED. C ON SUBSEQUENT CALLS (WHEN M0.NE.0) THE EQUATIONS ARE SOLVED C USING THE DECOMPOSITION OBTAINED ON THE INITIAL CALL TO DBSLV1. C C C INPUT ARGUMENTS WHEN M0=0 --- C C A,KA 2-DIMENSIONAL ARRAY OF DIMENSION (KA,M) WHERE C KA.GE.N AND M.GE.2*ML+MU+1. THE FIRST ML+MU+1 C COLUMNS CONTAIN THE MATRIX A IN BANDED FORM. C C N NUMBER OF EQUATIONS AND UNKNOWNS. C C ML NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL. C C MU NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL. C C B ARRAY OF N ENTRIES CONTAINING THE RIGHT HAND C SIDE DATA. C C C OUTPUT ARGUMENTS WHEN M0=0 --- C C A AN UPPER TIANGULAR MATRIX IN BAND STORAGE AND C THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT. C C B THE SOLUTION OF THE EQUATIONS. C C IWK ARRAY OF LENGTH N CONTAINING THE PIVOT INDICES. C C IERR INTEGER SPECIFYING THE STATUS OF THE RESULTS. C IERR=0 IF THE SOLUTION OF XA = B IS OBTAINED. C OTHERWISE IERR.NE.0. C C C AFTER AN INITIAL CALL TO DBSLV1, THE ROUTINE MAY BE RECALLED C WITH M0.NE.0 FOR A NEW B. WHEN M0.NE.0 IT IS ASSUMED THAT C A,KA,N,ML,MU,IWK HAVE NOT BEEN MODIFIED. DBSLV RETRIEVES THE C LU DECOMPOSITION WHICH WAS OBTAINED ON THE INITIAL CALL TO C DBSLV1 AND SOLVES THE NEW EQUATIONS XA = B. IN THIS CASE IERR C IS NOT REFERENCED. C ---------------------------------------------------------------------- DOUBLE PRECISION A(KA,*), B(N) INTEGER IWK(N) IF (M0 .NE. 0) GO TO 10 C C ERROR CHECKING C IF (N .LE. 0 .OR. N .GT. KA) GO TO 100 IF (ML .LT. 0 .OR. ML .GE. N) GO TO 110 IF (MU .LT. 0 .OR. MU .GE. N) GO TO 120 C C OBTAIN AN LU DECOMPOSITION OF A C CALL DBFA(A,KA,N,ML,MU,IWK,IERR) IF (IERR .NE. 0) RETURN C C SOLVE THE SYSTEM OF EQUATIONS C 10 CALL DBSL(A,KA,N,ML,MU,IWK,B,1) RETURN C C ERROR RETURN C 100 IERR = -1 RETURN 110 IERR = -2 RETURN 120 IERR = -3 RETURN END SUBROUTINE DBFA (A, LDA, N, ML, MU, IPVT, INFO) C ---------------------------------------------------------------------- C C DBFA FACTORS A REAL BAND MATRIX BY ELIMINATION. C C -------- C ON ENTRY C C A DOUBLE PRECISION(LDA, NC) C CONTAINS THE MATRIX IN BAND STORAGE. THE ROWS C OF THE ORIGINAL MATRIX ARE STORED IN THE ROWS C OF A AND THE DIAGONALS OF THE ORIGINAL MATRIX C ARE STORED IN COLUMNS 1 THROUGH ML+MU+1 OF A. C NC MUST BE .GE. 2*ML+MU+1 . C SEE THE COMMENTS BELOW FOR DETAILS. C C LDA INTEGER C THE LEADING DIMENSION OF THE ARRAY A. IT IS C ASSUMED THAT LDA .GE. N. C C N INTEGER C THE ORDER OF THE ORIGINAL MATRIX. C C ML INTEGER C NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL. C 0 .LE. ML .LT. N . C C MU INTEGER C NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL. C 0 .LE. MU .LT. N . C MORE EFFICIENT IF ML .LE. MU . C C ON RETURN C C A AN UPPER TRIANGULAR MATRIX IN BAND STORAGE C AND THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT. C THE FACTORIZATION CAN BE WRITTEN A = L*U WHERE C L IS A PRODUCT OF PERMUTATION AND UNIT LOWER C TRIANGULAR MATRICES AND U IS UPPER TRIANGULAR. C C IPVT INTEGER(N) C AN INTEGER VECTOR OF PIVOT INDICES. C C INFO INTEGER C =0 NORMAL VALUE C =K IF U(K,K) .EQ. 0. THIS IS NOT AN ERROR C CONDITION FOR THIS SUBROUTINE, BUT IT DOES C INDICATE THAT DBSL WILL DIVIDE BY ZERO IF C IT IS CALLED. C C BAND STORAGE C C IF A0 IS THE MATRIX THEN THE FOLLOWING CODE WILL STORE C A0 IN BAND FORM. C C ML = (BAND WIDTH BELOW THE DIAGONAL) C MU = (BAND WIDTH ABOVE THE DIAGONAL) C DO 20 I = 1, N C J1 = MAX0(1, I-ML) C J2 = MIN0(N, I+MU) C DO 10 J = J1, J2 C K = J - I + ML + 1 C A(I,K) = A0(I,J) C 10 CONTINUE C 20 CONTINUE C C THIS USES COLUMNS 1 THROUGH ML + MU + 1 OF A. C FURTHERMORE, ML ADDITIONAL COLUMNS ARE NEEDED IN C A (STARTING WITH COLUMN ML+MU+2) FOR ELEMENTS C GENERATED DURING THE TRIANGULARIZATION. THE TOTAL C NUMBER OF COLUMNS NEEDED IN A IS 2*ML+MU+1 . C C EXAMPLE.. IF THE ORIGINAL MATRIX IS C C 11 12 13 0 0 0 C 21 22 23 24 0 0 C 0 32 33 34 35 0 C 0 0 43 44 45 46 C 0 0 0 54 55 56 C 0 0 0 0 65 66 C C THEN N = 6, ML = 1, MU = 2, LDA .GE. 6 AND A SHOULD CONTAIN C C 11 12 13 + , + = USED FOR PIVOTING C 21 22 23 24 + C 32 33 34 35 + C 43 44 45 46 + C 54 55 56 + + C 65 66 + + + C C WRITTEN BY E.A.VOORHEES, LOS ALAMOS SCIENTIFIC LABORATORY. C MODIFIED BY A.H.MORRIS, NAVAL SURFACE WEAPONS CENTER. C C SUBROUTINES AND FUNCTIONS C MIN0,IDAMAX,DAXPY,DSCAL,DSWAP C ---------------------------------------------------------------------- INTEGER LDA,N,ML,MU,INFO DOUBLE PRECISION A(LDA,*) INTEGER IPVT(N) DOUBLE PRECISION T C INFO = 0 IF (ML .EQ. 0) GO TO 100 M = ML + MU + 1 C C SET FILL-IN COLUMNS TO ZERO C DO 11 J = 1,ML JJ = M + J DO 10 I = 1,N A(I,JJ) = 0.D0 10 CONTINUE 11 CONTINUE C C GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING C ML1 = ML + 1 MB = ML + MU N1 = N - 1 LDB = LDA - 1 DO 40 K = 1,N1 LM = MIN0(N-K,ML) LMK = LM + K LM1 = LM + 1 LM2 = ML1 - LM C C SEARCH FOR PIVOT INDEX C L = -IDAMAX(LM1, A(LMK,LM2), LDB) + LM1 + K IPVT(K) = L MP = MIN0(MB,N-K) C C SWAP ROWS IF NECESSARY C LL = ML1 + K - L IF (L .NE. K) CALL DSWAP(MP + 1, A(K,ML1), LDA, A(L,LL), LDA) C C SKIP COLUMN REDUCTION IF PIVOT IS ZERO C IF (A(K,ML1) .NE. 0.D0) GO TO 20 INFO = K GO TO 40 C C COMPUTE MULTIPLIERS C 20 T = -1.D0/A(K,ML1) CALL DSCAL(LM, T, A(LMK,LM2), LDB) C C ROW ELIMINATION WITH COLUMN INDEXING C DO 30 J = 1,MP JJ = ML1 + J J1 = LM2 + J CALL DAXPY(LM, A(K,JJ), A(LMK,LM2), LDB, A(LMK,J1), LDB) 30 CONTINUE 40 CONTINUE C IPVT(N) = N IF (A(N,ML1) .EQ. 0.D0) INFO = N RETURN C C CASE WHEN ML = 0 C 100 DO 110 K = 1,N IPVT(K) = K IF (A(K,1) .EQ. 0.D0) INFO = K 110 CONTINUE RETURN END SUBROUTINE DBSL (A,LDA,N,ML,MU,IPVT,B,JOB) C ---------------------------------------------------------------------- C C DBSL SOLVES THE REAL BAND SYSTEM A*X = B OR TRANS(A)*X = B C USING THE FACTORS COMPUTED BY DBFA. C C ---------- C ON ENTRY C C A DOUBLE PRECISION(LDA, NC) C THE OUTPUT FROM DBFA. C NC MUST BE .GE. 2*ML+MU+1 . C C LDA INTEGER C THE LEADING DIMENSION OF THE ARRAY A. C C N INTEGER C THE ORDER OF THE ORIGINAL MATRIX. C C ML INTEGER C NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL. C C MU INTEGER C NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL. C C IPVT INTEGER(N) C THE PIVOT VECTOR FROM DBFA. C C B DOUBLE PRECISION(N) C THE RIGHT HAND SIDE VECTOR. C C JOB INTEGER C = 0 TO SOLVE A*X = B . C = NONZERO TO SOLVE TRANS(A)*X = B , WHERE C TRANS(A) IS THE TRANSPOSE. C C ON RETURN C C B THE SOLUTION VECTOR X . C C ERROR CONDITION C C A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A C ZERO ON THE DIAGONAL. TECHNICALLY THIS INDICATES SINGULARITY C BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER C SETTING OF LDA. IT WILL NOT OCCUR IF DBFA AND DBSL ARE C CALLED CORRECTLY AND DBFA HAS SET INFO = 0. C C WRITTEN BY E.A. VOORHEES, LOS ALAMOS SCIENTIFIC LABORATORY. C MODIFIED BY A.H. MORRIS, NAVAL SURFACE WEAPONS CENTER. C C SUBROUTINES AND FUNCTIONS C DAXPY,DDOT C C FORTRAN MIN0 C ---------------------------------------------------------------------- INTEGER LDA,N,ML,MU,JOB DOUBLE PRECISION A(LDA,*),B(N) INTEGER IPVT(N) DOUBLE PRECISION DDOT,T INTEGER K,KB,KLM,L,LB,LDB,LM,M,MLM,NM1 C M = MU + ML + 1 IF (M .EQ. 1) GO TO 100 ML1 = ML + 1 ML2 = ML + 2 NM1 = N - 1 LDB = 1 - LDA IF (JOB .NE. 0) GO TO 50 C C JOB = 0 , SOLVE A * X = B C FIRST SOLVE L*Y = B C IF (ML .EQ. 0) GO TO 30 DO 20 K = 1,NM1 LM = MIN0(ML,N-K) L = IPVT(K) T = B(L) IF (L .EQ. K) GO TO 10 B(L) = B(K) B(K) = T 10 KLM = K + LM MLM = ML1 - LM CALL DAXPY(LM, T, A(KLM,MLM), LDB, B(K+1), 1) 20 CONTINUE C C NOW SOLVE U*X = Y C 30 K = N DO 40 KB = 2,N B(K) = B(K)/A(K,ML1) LM = MIN0(K,M) - 1 LB = K - LM T = -B(K) CALL DAXPY(LM, T, A(K-1,ML2), LDB, B(LB), 1) K = K - 1 40 CONTINUE B(1) = B(1)/A(1,ML1) RETURN C C JOB = NONZERO, SOLVE TRANS(A) * X = B C FIRST SOLVE TRANS(U)*Y = B C 50 B(1) = B(1)/A(1,ML1) DO 60 K = 2,N LM = MIN0(K,M) - 1 LB = K - LM T = DDOT(LM, A(K-1,ML2), LDB, B(LB), 1) B(K) = (B(K) - T)/A(K,ML1) 60 CONTINUE IF (ML .EQ. 0) RETURN C C NOW SOLVE TRANS(L)*X = Y C DO 70 KB = 1,NM1 K = N - KB LM = MIN0(ML,N-K) KLM = K + LM MLM = ML1 - LM B(K) = B(K) + DDOT(LM, A(KLM,MLM), LDB, B(K+1), 1) L = IPVT(K) IF (L .EQ. K) GO TO 70 T = B(L) B(L) = B(K) B(K) = T 70 CONTINUE RETURN C C CASE WHEN ML = 0 AND MU = 0 C 100 DO 110 K = 1,N 110 B(K) = B(K)/A(K,1) RETURN END SUBROUTINE B1CND (A, KA, N, ML, MU, COND, IWK, WK, IERR) C----------------------------------------------------------------------- C COMPUTATION OF THE L1 CONDITION NUMBER C OF A BANDED MATRIX A C----------------------------------------------------------------------- REAL A(KA,*), WK(*) INTEGER IWK(*) C----------------------- C REAL WK(2*N) C INTEGER IWK(2*N) C----------------------- COND = 0.0 IF (N .LE. 0 .OR. KA .LT. N) GO TO 100 IF (ML .LT. 0 .OR. ML .GE. N) GO TO 110 IF (MU .LT. 0 .OR. MU .GE. N) GO TO 120 C ANORM = B1NRM(A, KA, N, N, ML, MU) IF (ANORM .EQ. 0.0) GO TO 40 C IX = 1 IV = N + 1 ISGN = N + 1 C KASE = 0 AINORM = 0.0 CALL SONEST (N, WK(IV), WK(IX), IWK(ISGN), AINORM, KASE, * ITER, J, JUMP) CALL BSLV (0, A, KA, N, ML, MU, WK(IX), IWK(1), IERR) C C CHECK IF A IS SINGULAR C IF (IERR .GT. 0) GO TO 40 C C GENERAL LOOP TO ESTIMATE THE NORM AINORM C OF THE INVERSE OF A C 10 CALL SONEST (N, WK(IV), WK(IX), IWK(ISGN), AINORM, KASE, * ITER, J, JUMP) IF (KASE .EQ. 0) GO TO 30 IF (KASE .NE. 1) GO TO 20 CALL BSLV (1, A, KA, N, ML, MU, WK(IX), IWK(1), IERR) GO TO 10 20 CALL BSLV1 (1, A, KA, N, ML, MU, WK(IX), IWK(1), IERR) GO TO 10 C C COMPUTE THE VALUE OF COND C 30 COND = ANORM*AINORM RETURN C C SINGULAR CASE C 40 IERR = 1 RETURN C C ERROR RETURN C 100 IERR = -1 RETURN 110 IERR = -2 RETURN 120 IERR = -3 RETURN END SUBROUTINE DB1CND (A, KA, N, ML, MU, COND, IWK, WK, IERR) C----------------------------------------------------------------------- C COMPUTATION OF THE L1 CONDITION NUMBER OF C A DOUBLE PRECISION BANDED MATRIX A C----------------------------------------------------------------------- DOUBLE PRECISION A(KA,*), COND, WK(*) INTEGER IWK(*) DOUBLE PRECISION ANORM, AINORM DOUBLE PRECISION DB1NRM C----------------------- C DOUBLE PRECISION WK(2*N) C INTEGER IWK(2*N) C----------------------- COND = 0.D0 IF (N .LE. 0 .OR. KA .LT. N) GO TO 100 IF (ML .LT. 0 .OR. ML .GE. N) GO TO 110 IF (MU .LT. 0 .OR. MU .GE. N) GO TO 120 C ANORM = DB1NRM(A, KA, N, N, ML, MU) IF (ANORM .EQ. 0.D0) GO TO 40 C IX = 1 IV = N + 1 ISGN = N + 1 C KASE = 0 AINORM = 0.D0 CALL DONEST (N, WK(IV), WK(IX), IWK(ISGN), AINORM, KASE, * ITER, J, JUMP) CALL DBSLV (0, A, KA, N, ML, MU, WK(IX), IWK(1), IERR) C C CHECK IF A IS SINGULAR C IF (IERR .GT. 0) GO TO 40 C C GENERAL LOOP TO ESTIMATE THE NORM AINORM C OF THE INVERSE OF A C 10 CALL DONEST (N, WK(IV), WK(IX), IWK(ISGN), AINORM, KASE, * ITER, J, JUMP) IF (KASE .EQ. 0) GO TO 30 IF (KASE .NE. 1) GO TO 20 CALL DBSLV (1, A, KA, N, ML, MU, WK(IX), IWK(1), IERR) GO TO 10 20 CALL DBSLV1 (1, A, KA, N, ML, MU, WK(IX), IWK(1), IERR) GO TO 10 C C COMPUTE THE VALUE OF COND C 30 COND = ANORM*AINORM RETURN C C SINGULAR CASE C 40 IERR = 1 RETURN C C ERROR RETURN C 100 IERR = -1 RETURN 110 IERR = -2 RETURN 120 IERR = -3 RETURN END SUBROUTINE CBSLV(M0,A,KA,N,ML,MU,B,IWK,IERR) C ---------------------------------------------------------------------- C CBSLV EMPLOYS GAUSS ELIMINATION WITH ROW INTERCHANGES TO SOLVE C THE NXN COMPLEX BANDED SYSTEM AX = B. THE ARGUMENT M0 SPECIFIES C IF CBSLV IS BEING CALLED FOR THE FIRST TIME, OR IF IT IS BEING C RECALLED WHERE A IS THE SAME MATRIX BUT B HAS BEEN MODIFIED. C ON AN INITIAL CALL TO THE ROUTINE (WHEN M0=0) AN LU DECOMPO- C SITION OF A IS OBTAINED AND THEN THE EQUATIONS ARE SOLVED. C ON SUBSEQUENT CALLS (WHEN M0.NE.0) THE EQUATIONS ARE SOLVED C USING THE DECOMPOSITION OBTAINED ON THE INITIAL CALL TO CBSLV. C C C INPUT ARGUMENTS WHEN M0=0 --- C C A,KA 2-DIMENSIONAL ARRAY OF DIMENSION (KA,M) WHERE C KA.GE.N AND M.GE.2*ML+MU+1. THE FIRST ML+MU+1 C COLUMNS CONTAIN THE MATRIX A IN BANDED FORM. C A IS A COMPLEX ARRAY. C C N NUMBER OF EQUATIONS AND UNKNOWNS. C C ML NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL. C C MU NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL. C C B COMPLEX ARRAY OF N ENTRIES CONTAINING THE RIGHT C HAND SIDE DATA. C C C OUTPUT ARGUMENTS WHEN M0=0 --- C C A AN UPPER TIANGULAR MATRIX IN BAND STORAGE AND C THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT. C C B THE SOLUTION OF THE EQUATIONS. C C IWK ARRAY OF LENGTH N CONTAINING THE PIVOT INDICES. C C IERR INTEGER SPECIFYING THE STATUS OF THE RESULTS. C IERR=0 IF THE SOLUTION OF AX = B IS OBTAINED. C OTHERWISE IERR.NE.0. C C C AFTER AN INITIAL CALL TO CBSLV, THE ROUTINE MAY BE RECALLED C WITH M0.NE.0 FOR A NEW B. WHEN M0.NE.0 IT IS ASSUMED THAT C A,KA,N,ML,MU,IWK HAVE NOT BEEN MODIFIED. CBSLV RETRIEVES THE C LU DECOMPOSITION WHICH WAS OBTAINED ON THE INITIAL CALL TO C CBSLV AND SOLVES THE NEW EQUATIONS AX = B. IN THIS CASE IERR C IS NOT REFERENCED. C ---------------------------------------------------------------------- COMPLEX A(KA,*),B(N) INTEGER IWK(N) IF (M0 .NE. 0) GO TO 10 C C ERROR CHECKING C IF (N .LE. 0 .OR. N .GT. KA) GO TO 100 IF (ML .LT. 0 .OR. ML .GE. N) GO TO 110 IF (MU .LT. 0 .OR. MU .GE. N) GO TO 120 C C OBTAIN AN LU DECOMPOSITION OF A C CALL CBFA(A,KA,N,ML,MU,IWK,IERR) IF (IERR .NE. 0) RETURN C C SOLVE THE SYSTEM OF EQUATIONS C 10 CALL CBSL(A,KA,N,ML,MU,IWK,B,0) RETURN C C ERROR RETURN C 100 IERR = -1 RETURN 110 IERR = -2 RETURN 120 IERR = -3 RETURN END SUBROUTINE CBSLV1(M0,A,KA,N,ML,MU,B,IWK,IERR) C ---------------------------------------------------------------------- C CBSLV1 EMPLOYS GAUSS ELIMINATION WITH ROW INTERCHANGES TO SOLVE C THE NXN COMPLEX BANDED SYSTEM XA = B. THE ARGUMENT M0 SPECIFIES C IF CBSLV1 IS BEING CALLED FOR THE FIRST TIME, OR IF IT IS BEING C RECALLED WHERE A IS THE SAME MATRIX BUT B HAS BEEN MODIFIED. C ON AN INITIAL CALL TO THE ROUTINE (WHEN M0=0) AN LU DECOMPO- C SITION OF A IS OBTAINED AND THEN THE EQUATIONS ARE SOLVED. C ON SUBSEQUENT CALLS (WHEN M0.NE.0) THE EQUATIONS ARE SOLVED C USING THE DECOMPOSITION OBTAINED ON THE INITIAL CALL TO CBSLV1. C C C INPUT ARGUMENTS WHEN M0=0 --- C C A,KA 2-DIMENSIONAL ARRAY OF DIMENSION (KA,M) WHERE C KA.GE.N AND M.GE.2*ML+MU+1. THE FIRST ML+MU+1 C COLUMNS CONTAIN THE MATRIX A IN BANDED FORM. C A IS A COMPLEX ARRAY. C C N NUMBER OF EQUATIONS AND UNKNOWNS. C C ML NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL. C C MU NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL. C C B COMPLEX ARRAY OF N ENTRIES CONTAINING THE RIGHT C HAND SIDE DATA. C C C OUTPUT ARGUMENTS WHEN M0=0 --- C C A AN UPPER TIANGULAR MATRIX IN BAND STORAGE AND C THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT. C C B THE SOLUTION OF THE EQUATIONS. C C IWK ARRAY OF LENGTH N CONTAINING THE PIVOT INDICES. C C IERR INTEGER SPECIFYING THE STATUS OF THE RESULTS. C IERR=0 IF THE SOLUTION OF XA = B IS OBTAINED. C OTHERWISE IERR.NE.0. C C C AFTER AN INITIAL CALL TO CBSLV1, THE ROUTINE MAY BE RECALLED C WITH M0.NE.0 FOR A NEW B. WHEN M0.NE.0 IT IS ASSUMED THAT C A,KA,N,ML,MU,IWK HAVE NOT BEEN MODIFIED. CBSLV RETRIEVES THE C LU DECOMPOSITION WHICH WAS OBTAINED ON THE INITIAL CALL TO C CBSLV1 AND SOLVES THE NEW EQUATIONS XA = B. IN THIS CASE IERR C IS NOT REFERENCED. C ---------------------------------------------------------------------- COMPLEX A(KA,*),B(N) INTEGER IWK(N) IF (M0 .NE. 0) GO TO 10 C C ERROR CHECKING C IF (N .LE. 0 .OR. N .GT. KA) GO TO 100 IF (ML .LT. 0 .OR. ML .GE. N) GO TO 110 IF (MU .LT. 0 .OR. MU .GE. N) GO TO 120 C C OBTAIN AN LU DECOMPOSITION OF A C CALL CBFA(A,KA,N,ML,MU,IWK,IERR) IF (IERR .NE. 0) RETURN C C SOLVE THE SYSTEM OF EQUATIONS C 10 CALL CBSL(A,KA,N,ML,MU,IWK,B,1) RETURN C C ERROR RETURN C 100 IERR = -1 RETURN 110 IERR = -2 RETURN 120 IERR = -3 RETURN END SUBROUTINE CBFA (A, LDA, N, ML, MU, IPVT, INFO) C ---------------------------------------------------------------------- C C CBFA FACTORS A COMPLEX BAND MATRIX BY ELIMINATION. C C ---------- C ON ENTRY C C A COMPLEX(LDA, NC) C CONTAINS THE MATRIX IN BAND STORAGE. THE ROWS C OF THE ORIGINAL MATRIX ARE STORED IN THE ROWS C OF A AND THE DIAGONALS OF THE ORIGINAL MATRIX C ARE STORED IN COLUMNS 1 THROUGH ML+MU+1 OF A. C NC MUST BE .GE. 2*ML+MU+1 . C SEE THE COMMENTS BELOW FOR DETAILS. C C LDA INTEGER C THE LEADING DIMENSION OF THE ARRAY A. IT IS C ASSUMED THAT LDA .GE. N. C C N INTEGER C THE ORDER OF THE ORIGINAL MATRIX. C C ML INTEGER C NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL. C 0 .LE. ML .LT. N . C C MU INTEGER C NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL. C 0 .LE. MU .LT. N . C MORE EFFICIENT IF ML .LE. MU . C C ON RETURN C C A AN UPPER TRIANGULAR MATRIX IN BAND STORAGE C AND THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT. C THE FACTORIZATION CAN BE WRITTEN A = L*U WHERE C L IS A PRODUCT OF PERMUTATION AND UNIT LOWER C TRIANGULAR MATRICES AND U IS UPPER TRIANGULAR. C C IPVT INTEGER(N) C AN INTEGER VECTOR OF PIVOT INDICES. C C INFO INTEGER C =0 NORMAL VALUE C =K IF U(K,K) .EQ. 0. THIS IS NOT AN ERROR C CONDITION FOR THIS SUBROUTINE, BUT IT DOES C INDICATE THAT CBSL WILL DIVIDE BY ZERO IF C IT IS CALLED. C C BAND STORAGE C C IF A0 IS THE MATRIX THEN THE FOLLOWING CODE WILL STORE C A0 IN BAND FORM. C C ML = (BAND WIDTH BELOW THE DIAGONAL) C MU = (BAND WIDTH ABOVE THE DIAGONAL) C DO 20 I = 1, N C J1 = MAX0(1, I-ML) C J2 = MIN0(N, I+MU) C DO 10 J = J1, J2 C K = J - I + ML + 1 C A(I,K) = A0(I,J) C 10 CONTINUE C 20 CONTINUE C C THIS USES COLUMNS 1 THROUGH ML + MU + 1 OF A. C FURTHERMORE, ML ADDITIONAL COLUMNS ARE NEEDED IN C A (STARTING WITH COLUMN ML+MU+2) FOR ELEMENTS C GENERATED DURING THE TRIANGULARIZATION. THE TOTAL C NUMBER OF COLUMNS NEEDED IN A IS 2*ML+MU+1 . C C EXAMPLE.. IF THE ORIGINAL MATRIX IS C C 11 12 13 0 0 0 C 21 22 23 24 0 0 C 0 32 33 34 35 0 C 0 0 43 44 45 46 C 0 0 0 54 55 56 C 0 0 0 0 65 66 C C THEN N = 6, ML = 1, MU = 2, LDA .GE. 6 AND A SHOULD CONTAIN C C 11 12 13 + , + = USED FOR PIVOTING C 21 22 23 24 + C 32 33 34 35 + C 43 44 45 46 + C 54 55 56 + + C 65 66 + + + C C WRITTEN BY E.A.VOORHEES, LOS ALAMOS SCIENTIFIC LABORATORY. C MODIFIED BY A.H.MORRIS, NAVAL SURFACE WEAPONS CENTER. C C SUBROUTINES AND FUNCTIONS C MIN0,ICAMAX,CAXPY,CSCAL,CSWAP C ---------------------------------------------------------------------- INTEGER LDA,N,ML,MU,INFO COMPLEX A(LDA,*) INTEGER IPVT(N) COMPLEX T C INFO = 0 IF (ML .EQ. 0) GO TO 100 M = ML + MU + 1 C C SET FILL-IN COLUMNS TO ZERO C DO 11 J = 1,ML JJ = M + J DO 10 I = 1,N A(I,JJ) = (0.0,0.0) 10 CONTINUE 11 CONTINUE C C GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING C ML1 = ML + 1 MB = ML + MU N1 = N - 1 LDB = LDA - 1 DO 40 K = 1,N1 LM = MIN0(N-K,ML) LMK = LM + K LM1 = LM + 1 LM2 = ML1 - LM C C SEARCH FOR PIVOT INDEX C L = -ICAMAX(LM1, A(LMK,LM2), LDB) + LM1 + K IPVT(K) = L MP = MIN0(MB,N-K) C C SWAP ROWS IF NECESSARY C LL = ML1 + K - L IF (L .NE. K) CALL CSWAP(MP + 1, A(K,ML1), LDA, A(L,LL), LDA) C C SKIP COLUMN REDUCTION IF PIVOT IS ZERO C IF (A(K,ML1) .NE. (0.0,0.0)) GO TO 20 INFO = K GO TO 40 C C COMPUTE MULTIPLIERS C 20 T = (-1.0,0.0)/A(K,ML1) CALL CSCAL(LM, T, A(LMK,LM2), LDB) C C ROW ELIMINATION WITH COLUMN INDEXING C DO 30 J = 1,MP JJ = ML1 + J J1 = LM2 + J CALL CAXPY(LM, A(K,JJ), A(LMK,LM2), LDB, A(LMK,J1), LDB) 30 CONTINUE 40 CONTINUE C IPVT(N) = N IF (A(N,ML1) .EQ. (0.0,0.0)) INFO = N RETURN C C CASE WHEN ML = 0 C 100 DO 110 K = 1,N IPVT(K) = K IF (A(K,1) .EQ. (0.0,0.0)) INFO = K 110 CONTINUE RETURN END SUBROUTINE CBSL (A,LDA,N,ML,MU,IPVT,B,JOB) C ---------------------------------------------------------------------- C C CBSL SOLVES THE COMPLEX BAND SYSTEM A*X = B OR TRANS(A)*X = B C USING THE FACTORS COMPUTED BY CBFA. C C ---------- C ON ENTRY C C A COMPLEX(LDA, NC) C THE OUTPUT FROM CBFA. C NC MUST BE .GE. 2*ML+MU+1 . C C LDA INTEGER C THE LEADING DIMENSION OF THE ARRAY A. C C N INTEGER C THE ORDER OF THE ORIGINAL MATRIX. C C ML INTEGER C NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL. C C MU INTEGER C NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL. C C IPVT INTEGER(N) C THE PIVOT VECTOR FROM CBFA. C C B COMPLEX(N) C THE RIGHT HAND SIDE VECTOR. C C JOB INTEGER C = 0 TO SOLVE A*X = B . C = NONZERO TO SOLVE TRANS(A)*X = B , WHERE C TRANS(A) IS THE TRANSPOSE. C C ON RETURN C C B THE SOLUTION VECTOR X . C C ERROR CONDITION C C A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A C ZERO ON THE DIAGONAL. TECHNICALLY THIS INDICATES SINGULARITY C BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER C SETTING OF LDA. IT WILL NOT OCCUR IF CBFA AND CBSL ARE C CALLED CORRECTLY AND CBFA HAS SET INFO = 0. C C WRITTEN BY E.A. VOORHEES, LOS ALAMOS SCIENTIFIC LABORATORY. C ADAPTED BY A.H. MORRIS, NAVAL SURFACE WEAPONS CENTER. C C SUBROUTINES AND FUNCTIONS C CAXPY,CDOTU C C FORTRAN MIN0 C ---------------------------------------------------------------------- INTEGER LDA,N,ML,MU,JOB COMPLEX A(LDA,*),B(N) INTEGER IPVT(N) COMPLEX CDOTU,T INTEGER K,KB,KLM,L,LB,LDB,LM,M,MLM,NM1 C M = MU + ML + 1 IF (M .EQ. 1) GO TO 100 ML1 = ML + 1 ML2 = ML + 2 NM1 = N - 1 LDB = 1 - LDA IF (JOB .NE. 0) GO TO 50 C C JOB = 0 , SOLVE A * X = B C FIRST SOLVE L*Y = B C IF (ML .EQ. 0) GO TO 30 DO 20 K = 1,NM1 LM = MIN0(ML,N-K) L = IPVT(K) T = B(L) IF (L .EQ. K) GO TO 10 B(L) = B(K) B(K) = T 10 KLM = K + LM MLM = ML1 - LM CALL CAXPY(LM, T, A(KLM,MLM), LDB, B(K+1), 1) 20 CONTINUE C C NOW SOLVE U*X = Y C 30 K = N DO 40 KB = 2,N B(K) = B(K)/A(K,ML1) LM = MIN0(K,M) - 1 LB = K - LM T = -B(K) CALL CAXPY(LM, T, A(K-1,ML2), LDB, B(LB), 1) K = K - 1 40 CONTINUE B(1) = B(1)/A(1,ML1) RETURN C C JOB = NONZERO, SOLVE TRANS(A) * X = B C FIRST SOLVE TRANS(U)*Y = B C 50 B(1) = B(1)/A(1,ML1) DO 60 K = 2,N LM = MIN0(K,M) - 1 LB = K - LM T = CDOTU(LM, A(K-1,ML2), LDB, B(LB), 1) B(K) = (B(K) - T)/A(K,ML1) 60 CONTINUE IF (ML .EQ. 0) RETURN C C NOW SOLVE TRANS(L)*X = Y C DO 70 KB = 1, NM1 K = N - KB LM = MIN0(ML,N-K) KLM = K + LM MLM = ML1 - LM B(K) = B(K) + CDOTU(LM, A(KLM,MLM), LDB, B(K+1), 1) L = IPVT(K) IF (L .EQ. K) GO TO 70 T = B(L) B(L) = B(K) B(K) = T 70 CONTINUE RETURN C C CASE WHEN ML = 0 AND MU = 0 C 100 DO 110 K = 1,N 110 B(K) = B(K)/A(K,1) RETURN END SUBROUTINE CVRS (A, KA, M, N, B, IB, JB, NUM, IERR) REAL A(KA,N), B(*) INTEGER IB(*), JB(*) C C STORE THE I-TH ROW C IP = 1 DO 11 I = 1,M IB(I) = IP DO 10 J = 1,N IF (A(I,J) .EQ. 0.0) GO TO 10 IF (IP .GT. NUM) GO TO 20 B(IP) = A(I,J) JB(IP) = J IP = IP + 1 10 CONTINUE 11 CONTINUE C C COMPLETE THE SETUP C IB(M + 1) = IP IERR = 0 RETURN C C ERROR RETURN C 20 IERR = I RETURN END SUBROUTINE CVDS (A, KA, M, N, B, IB, JB, NUM, IERR) DOUBLE PRECISION A(KA,N), B(*) INTEGER IB(*), JB(*) C C STORE THE I-TH ROW C IP = 1 DO 11 I = 1,M IB(I) = IP DO 10 J = 1,N IF (A(I,J) .EQ. 0.D0) GO TO 10 IF (IP .GT. NUM) GO TO 20 B(IP) = A(I,J) JB(IP) = J IP = IP + 1 10 CONTINUE 11 CONTINUE C C COMPLETE THE SETUP C IB(M + 1) = IP IERR = 0 RETURN C C ERROR RETURN C 20 IERR = I RETURN END SUBROUTINE CVCS (A, KA, M, N, B, IB, JB, NUM, IERR) COMPLEX A(KA,N), B(*), ZERO INTEGER IB(*), JB(*) DATA ZERO /(0.0,0.0)/ C C STORE THE I-TH ROW C IP = 1 DO 11 I = 1,M IB(I) = IP DO 10 J = 1,N IF (A(I,J) .EQ. ZERO) GO TO 10 IF (IP .GT. NUM) GO TO 20 B(IP) = A(I,J) JB(IP) = J IP = IP + 1 10 CONTINUE 11 CONTINUE C C COMPLETE THE SETUP C IB(M + 1) = IP IERR = 0 RETURN C C ERROR RETURN C 20 IERR = I RETURN END SUBROUTINE CVSR (A, IA, JA, B, KB, M, N) REAL A(*), B(KB,N) INTEGER IA(*), JA(*) C DO 30 I = 1,M C C CLEAR THE I-TH ROW C DO 10 J = 1,N B(I,J) = 0.0 10 CONTINUE C C STORE THE I-TH ROW C IPMIN = IA(I) IPMAX = IA(I+1) - 1 IF (IPMIN .GT. IPMAX) GO TO 30 DO 20 IP = IPMIN,IPMAX J = JA(IP) B(I,J) = A(IP) 20 CONTINUE C 30 CONTINUE RETURN END SUBROUTINE CVSD (A, IA, JA, B, KB, M, N) DOUBLE PRECISION A(*), B(KB,N) INTEGER IA(*), JA(*) C DO 30 I = 1,M C C CLEAR THE I-TH ROW C DO 10 J = 1,N B(I,J) = 0.D0 10 CONTINUE C C STORE THE I-TH ROW C IPMIN = IA(I) IPMAX = IA(I+1) - 1 IF (IPMIN .GT. IPMAX) GO TO 30 DO 20 IP = IPMIN,IPMAX J = JA(IP) B(I,J) = A(IP) 20 CONTINUE C 30 CONTINUE RETURN END SUBROUTINE CVSC (A, IA, JA, B, KB, M, N) COMPLEX A(*), B(KB,N) INTEGER IA(*), JA(*) C DO 30 I = 1,M C C CLEAR THE I-TH ROW C DO 10 J = 1,N B(I,J) = (0.0,0.0) 10 CONTINUE C C STORE THE I-TH ROW C IPMIN = IA(I) IPMAX = IA(I+1) - 1 IF (IPMIN .GT. IPMAX) GO TO 30 DO 20 IP = IPMIN,IPMAX J = JA(IP) B(I,J) = A(IP) 20 CONTINUE C 30 CONTINUE RETURN END SUBROUTINE SCVRD (A, IA, JA, B, IB, JB, M) REAL A(*) DOUBLE PRECISION B(*) INTEGER IA(*), JA(*), IB(*), JB(*) C L = 1 DO 20 I = 1,M IB(I) = L IBEG = IA(I) IEND = IA(I+1) - 1 IF (IBEG .GT. IEND) GO TO 20 DO 10 IP = IBEG,IEND IF (A(IP) .EQ. 0.0) GO TO 10 B(L) = A(IP) JB(L) = JA(IP) L = L + 1 10 CONTINUE 20 CONTINUE IB(M + 1) = L RETURN END SUBROUTINE SCVDR (A, IA, JA, B, IB, JB, M) DOUBLE PRECISION A(*) REAL B(*) INTEGER IA(*), JA(*), IB(*), JB(*) C L = 1 DO 20 I = 1,M IB(I) = L IBEG = IA(I) IEND = IA(I+1) - 1 IF (IBEG .GT. IEND) GO TO 20 DO 10 IP = IBEG,IEND IF (A(IP) .EQ. 0.D0) GO TO 10 B(L) = A(IP) JB(L) = JA(IP) L = L + 1 10 CONTINUE 20 CONTINUE IB(M + 1) = L RETURN END SUBROUTINE CSREAL (A, IA, JA, B, IB, JB, M) C----------------------------------------------------------------------- C REAL PART OF A SPARSE COMPLEX MATRIX C----------------------------------------------------------------------- COMPLEX A(*) REAL B(*) INTEGER IA(*), JA(*), IB(*), JB(*) C L = 1 DO 20 I = 1,M IB(I) = L IBEG = IA(I) IEND = IA(I+1) - 1 IF (IBEG .GT. IEND) GO TO 20 DO 10 IP = IBEG,IEND T = REAL(A(IP)) IF (T .EQ. 0.0) GO TO 10 B(L) = T JB(L) = JA(IP) L = L + 1 10 CONTINUE 20 CONTINUE IB(M + 1) = L RETURN END SUBROUTINE CSIMAG (A, IA, JA, B, IB, JB, M) C----------------------------------------------------------------------- C IMAGINARY PART OF A SPARSE COMPLEX MATRIX C----------------------------------------------------------------------- COMPLEX A(*) REAL B(*) INTEGER IA(*), JA(*), IB(*), JB(*) C L = 1 DO 20 I = 1,M IB(I) = L IBEG = IA(I) IEND = IA(I+1) - 1 IF (IBEG .GT. IEND) GO TO 20 DO 10 IP = IBEG,IEND T = AIMAG(A(IP)) IF (T .EQ. 0.0) GO TO 10 B(L) = T JB(L) = JA(IP) L = L + 1 10 CONTINUE 20 CONTINUE IB(M + 1) = L RETURN END SUBROUTINE SCVRC (A,IA,JA,B,IB,JB,C,IC,JC,M,N,NUM,WK,IERR) C----------------------------------------------------------------------- C COMPUTE A + BI FOR THE SPARSE REAL MATRICES A AND B C----------------------------------------------------------------------- REAL A(*), B(*), WK(N) COMPLEX C(*), T INTEGER IA(*), JA(*), IB(*), JB(*), IC(*), JC(*) C------------------------- DO 10 J = 1,N WK(J) = 0.0 10 CONTINUE C C COMPUTE THE I-TH ROW OF C C IP = 1 DO 42 I = 1,M IC(I) = IP MINA = IA(I) MAXA = IA(I+1) - 1 IF (MINA .GT. MAXA) GO TO 30 DO 20 L = MINA,MAXA J = JA(L) WK(J) = A(L) 20 CONTINUE C 30 MINB = IB(I) MAXB = IB(I+1) - 1 IF (MINB .GT. MAXB) GO TO 40 DO 31 L = MINB,MAXB IF (B(L) .EQ. 0.0) GO TO 31 J = JB(L) T = CMPLX (WK(J), B(L)) WK(J) = 0.0 IF (IP .GT. NUM) GO TO 50 C(IP) = T JC(IP) = J IP = IP + 1 31 CONTINUE C 40 IF (MINA .GT. MAXA) GO TO 42 DO 41 L = MINA,MAXA J = JA(L) IF (WK(J) .EQ. 0.0) GO TO 41 IF (IP .GT. NUM) GO TO 50 C(IP) = CMPLX (WK(J), 0.0) WK(J) = 0.0 JC(IP) = J IP = IP + 1 41 CONTINUE 42 CONTINUE IC(M + 1) = IP IERR = 0 RETURN C C ERROR RETURN C 50 IERR = I RETURN END SUBROUTINE RSCOPY (A, IA, JA, B, IB, JB, M) C----------------------------------------------------------------------- C COPYING A SPARSE REAL MATRIX C----------------------------------------------------------------------- REAL A(*), B(*) INTEGER IA(*), JA(*), IB(*), JB(*) C L = 1 DO 20 I = 1,M IB(I) = L IBEG = IA(I) IEND = IA(I+1) - 1 IF (IBEG .GT. IEND) GO TO 20 DO 10 IP = IBEG,IEND IF (A(IP) .EQ. 0.0) GO TO 10 B(L) = A(IP) JB(L) = JA(IP) L = L + 1 10 CONTINUE 20 CONTINUE IB(M + 1) = L RETURN END SUBROUTINE DSCOPY (A, IA, JA, B, IB, JB, M) C----------------------------------------------------------------------- C COPYING A SPARSE DOUBLE PRECISION MATRIX C----------------------------------------------------------------------- DOUBLE PRECISION A(*), B(*) INTEGER IA(*), JA(*), IB(*), JB(*) C L = 1 DO 20 I = 1,M IB(I) = L IBEG = IA(I) IEND = IA(I+1) - 1 IF (IBEG .GT. IEND) GO TO 20 DO 10 IP = IBEG,IEND IF (A(IP) .EQ. 0.D0) GO TO 10 B(L) = A(IP) JB(L) = JA(IP) L = L + 1 10 CONTINUE 20 CONTINUE IB(M + 1) = L RETURN END SUBROUTINE CSCOPY (A, IA, JA, B, IB, JB, M) C----------------------------------------------------------------------- C COPYING A SPARSE COMPLEX MATRIX C----------------------------------------------------------------------- COMPLEX A(*), B(*), ZERO INTEGER IA(*), JA(*), IB(*), JB(*) DATA ZERO /(0.0,0.0)/ C L = 1 DO 20 I = 1,M IB(I) = L IBEG = IA(I) IEND = IA(I+1) - 1 IF (IBEG .GT. IEND) GO TO 20 DO 10 IP = IBEG,IEND IF (A(IP) .EQ. ZERO) GO TO 10 B(L) = A(IP) JB(L) = JA(IP) L = L + 1 10 CONTINUE 20 CONTINUE IB(M + 1) = L RETURN END SUBROUTINE SCONJ (A, IA, JA, B, IB, JB, M) C----------------------------------------------------------------------- C COMPUTATION OF THE CONJUGATE OF A SPARSE COMPLEX MATRIX C----------------------------------------------------------------------- COMPLEX A(*), B(*) INTEGER IA(*), JA(*), IB(*), JB(*) C MP1 = M + 1 L = IA(1) - 1 DO 10 I = 1,MP1 IB(I) = IA(I) - L 10 CONTINUE C IBEG = IA(1) IEND = IA(MP1) - 1 IF (IBEG .GT. IEND) RETURN L = 1 DO 20 IP = IBEG,IEND B(L) = CONJG(A(IP)) JB(L) = JA(IP) L = L + 1 20 CONTINUE RETURN END SUBROUTINE RPOSE (A, IA, JA, B, IB, JB, M, N) C----------------------------------------------------------------------- C TRANSPOSING A SPARSE REAL MATRIX C----------------------------------------------------------------------- REAL A(*), B(*) INTEGER IA(*), JA(*), IB(*), JB(*) C C COMPUTE THE NUMBER OF ELEMENTS IN EACH COLUMN C OF A AND STORE THE RESULTS IN IB C IPMIN = IA(1) IPMAX = IA(M+1) - 1 IF (IPMIN .GT. IPMAX) GO TO 40 DO 10 J = 1,N IB(J) = 0 10 CONTINUE DO 11 IP = IPMIN,IPMAX J = JA(IP) IB(J) = IB(J) + 1 11 CONTINUE C C COMPUTE THE ROW POINTERS OF THE TRANSPOSE MATRIX C AND STORE THEM IN IB(2),...,IB(N+1) C NUM = IA(M+1) - IA(1) + 1 J = N DO 20 JJ = 1,N NUM = NUM - IB(J) IB(J+1) = NUM J = J - 1 20 CONTINUE C C STORE THE I-TH ROW OF A IN B AND JB C AND UPDATE THE POINTERS IN IB C DO 31 I = 1,M IPMIN = IA(I) IPMAX = IA(I+1) - 1 IF (IPMIN .GT. IPMAX) GO TO 31 DO 30 IP = IPMIN,IPMAX J = JA(IP) JP = IB(J+1) JB(JP) = I B(JP) = A(IP) IB(J+1) = JP + 1 30 CONTINUE 31 CONTINUE IB(1) = 1 RETURN C C TRANSPOSE A ZERO MATRIX A C 40 NP1 = N + 1 DO 41 J = 1,NP1 IB(J) = 1 41 CONTINUE RETURN END SUBROUTINE RPOSE1 (P, A, IA, JA, B, IB, JB, M, N) C----------------------------------------------------------------------- C TRANSPOSING A SPARSE REAL MATRIX C WHERE THE ROWS ARE INTERCHANGED C----------------------------------------------------------------------- INTEGER P(M) REAL A(*), B(*) INTEGER IA(*), JA(*), IB(*), JB(*) C C COMPUTE THE NUMBER OF ELEMENTS IN EACH COLUMN C OF A AND STORE THE RESULTS IN IB C IPMIN = IA(1) IPMAX = IA(M+1) - 1 IF (IPMIN .GT. IPMAX) GO TO 40 DO 10 J = 1,N IB(J) = 0 10 CONTINUE DO 11 IP = IPMIN,IPMAX J = JA(IP) IB(J) = IB(J) + 1 11 CONTINUE C C COMPUTE THE ROW POINTERS OF THE TRANSPOSE MATRIX C AND STORE THEM IN IB(2),...,IB(N+1) C NUM = IA(M+1) - IA(1) + 1 J = N DO 20 JJ = 1,N NUM = NUM - IB(J) IB(J+1) = NUM J = J - 1 20 CONTINUE C C STORE THE I-TH ROW OF A IN B AND JB C AND UPDATE THE POINTERS IN IB C DO 31 I = 1,M II = P(I) IPMIN = IA(II) IPMAX = IA(II+1) - 1 IF (IPMIN .GT. IPMAX) GO TO 31 DO 30 IP = IPMIN,IPMAX J = JA(IP) JP = IB(J+1) JB(JP) = I B(JP) = A(IP) IB(J+1) = JP + 1 30 CONTINUE 31 CONTINUE IB(1) = 1 RETURN C C TRANSPOSE A ZERO MATRIX A C 40 NP1 = N + 1 DO 41 J = 1,NP1 IB(J) = 1 41 CONTINUE RETURN END SUBROUTINE DPOSE (A, IA, JA, B, IB, JB, M, N) C----------------------------------------------------------------------- C TRANSPOSING A SPARSE DOUBLE PRECISION MATRIX C----------------------------------------------------------------------- DOUBLE PRECISION A(*), B(*) INTEGER IA(*), JA(*), IB(*), JB(*) C C COMPUTE THE NUMBER OF ELEMENTS IN EACH COLUMN C OF A AND STORE THE RESULTS IN IB C IPMIN = IA(1) IPMAX = IA(M+1) - 1 IF (IPMIN .GT. IPMAX) GO TO 40 DO 10 J = 1,N IB(J) = 0 10 CONTINUE DO 11 IP = IPMIN,IPMAX J = JA(IP) IB(J) = IB(J) + 1 11 CONTINUE C C COMPUTE THE ROW POINTERS OF THE TRANSPOSE MATRIX C AND STORE THEM IN IB(2),...,IB(N+1) C NUM = IA(M+1) - IA(1) + 1 J = N DO 20 JJ = 1,N NUM = NUM - IB(J) IB(J+1) = NUM J = J - 1 20 CONTINUE C C STORE THE I-TH ROW OF A IN B AND JB C AND UPDATE THE POINTERS IN IB C DO 31 I = 1,M IPMIN = IA(I) IPMAX = IA(I+1) - 1 IF (IPMIN .GT. IPMAX) GO TO 31 DO 30 IP = IPMIN,IPMAX J = JA(IP) JP = IB(J+1) JB(JP) = I B(JP) = A(IP) IB(J+1) = JP + 1 30 CONTINUE 31 CONTINUE IB(1) = 1 RETURN C C TRANSPOSE A ZERO MATRIX A C 40 NP1 = N + 1 DO 41 J = 1,NP1 IB(J) = 1 41 CONTINUE RETURN END SUBROUTINE DPOSE1 (P, A, IA, JA, B, IB, JB, M, N) C----------------------------------------------------------------------- C TRANSPOSING A SPARSE DOUBLE PRECISION MATRIX C WHERE THE ROWS ARE INTERCHANGED C----------------------------------------------------------------------- INTEGER P(M) DOUBLE PRECISION A(*), B(*) INTEGER IA(*), JA(*), IB(*), JB(*) C C COMPUTE THE NUMBER OF ELEMENTS IN EACH COLUMN C OF A AND STORE THE RESULTS IN IB C IPMIN = IA(1) IPMAX = IA(M+1) - 1 IF (IPMIN .GT. IPMAX) GO TO 40 DO 10 J = 1,N IB(J) = 0 10 CONTINUE DO 11 IP = IPMIN,IPMAX J = JA(IP) IB(J) = IB(J) + 1 11 CONTINUE C C COMPUTE THE ROW POINTERS OF THE TRANSPOSE MATRIX C AND STORE THEM IN IB(2),...,IB(N+1) C NUM = IA(M+1) - IA(1) + 1 J = N DO 20 JJ = 1,N NUM = NUM - IB(J) IB(J+1) = NUM J = J - 1 20 CONTINUE C C STORE THE I-TH ROW OF A IN B AND JB C AND UPDATE THE POINTERS IN IB C DO 31 I = 1,M II = P(I) IPMIN = IA(II) IPMAX = IA(II+1) - 1 IF (IPMIN .GT. IPMAX) GO TO 31 DO 30 IP = IPMIN,IPMAX J = JA(IP) JP = IB(J+1) JB(JP) = I B(JP) = A(IP) IB(J+1) = JP + 1 30 CONTINUE 31 CONTINUE IB(1) = 1 RETURN C C TRANSPOSE A ZERO MATRIX A C 40 NP1 = N + 1 DO 41 J = 1,NP1 IB(J) = 1 41 CONTINUE RETURN END SUBROUTINE CPOSE (A, IA, JA, B, IB, JB, M, N) C----------------------------------------------------------------------- C TRANSPOSING A SPARSE COMPLEX MATRIX C----------------------------------------------------------------------- COMPLEX A(*), B(*) INTEGER IA(*), JA(*), IB(*), JB(*) C C COMPUTE THE NUMBER OF ELEMENTS IN EACH COLUMN C OF A AND STORE THE RESULTS IN IB C IPMIN = IA(1) IPMAX = IA(M+1) - 1 IF (IPMIN .GT. IPMAX) GO TO 40 DO 10 J = 1,N IB(J) = 0 10 CONTINUE DO 11 IP = IPMIN,IPMAX J = JA(IP) IB(J) = IB(J) + 1 11 CONTINUE C C COMPUTE THE ROW POINTERS OF THE TRANSPOSE MATRIX C AND STORE THEM IN IB(2),...,IB(N+1) C NUM = IA(M+1) - IA(1) + 1 J = N DO 20 JJ = 1,N NUM = NUM - IB(J) IB(J+1) = NUM J = J - 1 20 CONTINUE C C STORE THE I-TH ROW OF A IN B AND JB C AND UPDATE THE POINTERS IN IB C DO 31 I = 1,M IPMIN = IA(I) IPMAX = IA(I+1) - 1 IF (IPMIN .GT. IPMAX) GO TO 31 DO 30 IP = IPMIN,IPMAX J = JA(IP) JP = IB(J+1) JB(JP) = I B(JP) = A(IP) IB(J+1) = JP + 1 30 CONTINUE 31 CONTINUE IB(1) = 1 RETURN C C TRANSPOSE A ZERO MATRIX A C 40 NP1 = N + 1 DO 41 J = 1,NP1 IB(J) = 1 41 CONTINUE RETURN END SUBROUTINE CPOSE1 (P, A, IA, JA, B, IB, JB, M, N) C----------------------------------------------------------------------- C TRANSPOSING A SPARSE COMPLEX MATRIX C WHERE THE ROWS ARE INTERCHANGED C----------------------------------------------------------------------- INTEGER P(M) COMPLEX A(*), B(*) INTEGER IA(*), JA(*), IB(*), JB(*) C C COMPUTE THE NUMBER OF ELEMENTS IN EACH COLUMN C OF A AND STORE THE RESULTS IN IB C IPMIN = IA(1) IPMAX = IA(M+1) - 1 IF (IPMIN .GT. IPMAX) GO TO 40 DO 10 J = 1,N IB(J) = 0 10 CONTINUE DO 11 IP = IPMIN,IPMAX J = JA(IP) IB(J) = IB(J) + 1 11 CONTINUE C C COMPUTE THE ROW POINTERS OF THE TRANSPOSE MATRIX C AND STORE THEM IN IB(2),...,IB(N+1) C NUM = IA(M+1) - IA(1) + 1 J = N DO 20 JJ = 1,N NUM = NUM - IB(J) IB(J+1) = NUM J = J - 1 20 CONTINUE C C STORE THE I-TH ROW OF A IN B AND JB C AND UPDATE THE POINTERS IN IB C DO 31 I = 1,M II = P(I) IPMIN = IA(II) IPMAX = IA(II+1) - 1 IF (IPMIN .GT. IPMAX) GO TO 31 DO 30 IP = IPMIN,IPMAX J = JA(IP) JP = IB(J+1) JB(JP) = I B(JP) = A(IP) IB(J+1) = JP + 1 30 CONTINUE 31 CONTINUE IB(1) = 1 RETURN C C TRANSPOSE A ZERO MATRIX A C 40 NP1 = N + 1 DO 41 J = 1,NP1 IB(J) = 1 41 CONTINUE RETURN END SUBROUTINE SADD (A,IA,JA,B,IB,JB,C,IC,JC,M,N,NUM,WK,IERR) C----------------------------------------------------------------------- C ADDITION OF SPARSE REAL MATRICES C----------------------------------------------------------------------- REAL A(*), B(*), C(*), WK(N), T INTEGER IA(*), JA(*), IB(*), JB(*), IC(*), JC(*) C------------------------- DO 10 J = 1,N WK(J) = 0.0 10 CONTINUE C C COMPUTE THE I-TH ROW OF C C IP = 1 DO 42 I = 1,M IC(I) = IP MINA = IA(I) MAXA = IA(I+1) - 1 IF (MINA .GT. MAXA) GO TO 30 DO 20 L = MINA,MAXA J = JA(L) WK(J) = A(L) 20 CONTINUE C 30 MINB = IB(I) MAXB = IB(I+1) - 1 IF (MINB .GT. MAXB) GO TO 40 DO 31 L = MINB,MAXB J = JB(L) T = WK(J) + B(L) WK(J) = 0.0 IF (T .EQ. 0.0) GO TO 31 IF (IP .GT. NUM) GO TO 50 C(IP) = T JC(IP) = J IP = IP + 1 31 CONTINUE C 40 IF (MINA .GT. MAXA) GO TO 42 DO 41 L = MINA,MAXA J = JA(L) IF (WK(J) .EQ. 0.0) GO TO 41 IF (IP .GT. NUM) GO TO 50 C(IP) = WK(J) WK(J) = 0.0 JC(IP) = J IP = IP + 1 41 CONTINUE 42 CONTINUE IC(M + 1) = IP IERR = 0 RETURN C C ERROR RETURN C 50 IERR = I RETURN END SUBROUTINE DSADD (A,IA,JA,B,IB,JB,C,IC,JC,M,N,NUM,WK,IERR) C----------------------------------------------------------------------- C ADDITION OF SPARSE DOUBLE PRECISION MATRICES C----------------------------------------------------------------------- DOUBLE PRECISION A(*), B(*), C(*), WK(N), T INTEGER IA(*), JA(*), IB(*), JB(*), IC(*), JC(*) C------------------------- DO 10 J = 1,N WK(J) = 0.D0 10 CONTINUE C C COMPUTE THE I-TH ROW OF C C IP = 1 DO 42 I = 1,M IC(I) = IP MINA = IA(I) MAXA = IA(I+1) - 1 IF (MINA .GT. MAXA) GO TO 30 DO 20 L = MINA,MAXA J = JA(L) WK(J) = A(L) 20 CONTINUE C 30 MINB = IB(I) MAXB = IB(I+1) - 1 IF (MINB .GT. MAXB) GO TO 40 DO 31 L = MINB,MAXB J = JB(L) T = WK(J) + B(L) WK(J) = 0.D0 IF (T .EQ. 0.D0) GO TO 31 IF (IP .GT. NUM) GO TO 50 C(IP) = T JC(IP) = J IP = IP + 1 31 CONTINUE C 40 IF (MINA .GT. MAXA) GO TO 42 DO 41 L = MINA,MAXA J = JA(L) IF (WK(J) .EQ. 0.D0) GO TO 41 IF (IP .GT. NUM) GO TO 50 C(IP) = WK(J) WK(J) = 0.D0 JC(IP) = J IP = IP + 1 41 CONTINUE 42 CONTINUE IC(M + 1) = IP IERR = 0 RETURN C C ERROR RETURN C 50 IERR = I RETURN END SUBROUTINE CSADD (A,IA,JA,B,IB,JB,C,IC,JC,M,N,NUM,WK,IERR) C----------------------------------------------------------------------- C ADDITION OF SPARSE COMPLEX MATRICES C----------------------------------------------------------------------- COMPLEX A(*), B(*), C(*), WK(N), T INTEGER IA(*), JA(*), IB(*), JB(*), IC(*), JC(*) C------------------------- DO 10 J = 1,N WK(J) = (0.0, 0.0) 10 CONTINUE C C COMPUTE THE I-TH ROW OF C C IP = 1 DO 42 I = 1,M IC(I) = IP MINA = IA(I) MAXA = IA(I+1) - 1 IF (MINA .GT. MAXA) GO TO 30 DO 20 L = MINA,MAXA J = JA(L) WK(J) = A(L) 20 CONTINUE C 30 MINB = IB(I) MAXB = IB(I+1) - 1 IF (MINB .GT. MAXB) GO TO 40 DO 31 L = MINB,MAXB J = JB(L) T = WK(J) + B(L) WK(J) = (0.0, 0.0) IF (T .EQ. (0.0, 0.0)) GO TO 31 IF (IP .GT. NUM) GO TO 50 C(IP) = T JC(IP) = J IP = IP + 1 31 CONTINUE C 40 IF (MINA .GT. MAXA) GO TO 42 DO 41 L = MINA,MAXA J = JA(L) IF (WK(J) .EQ. (0.0, 0.0)) GO TO 41 IF (IP .GT. NUM) GO TO 50 C(IP) = WK(J) WK(J) = (0.0, 0.0) JC(IP) = J IP = IP + 1 41 CONTINUE 42 CONTINUE IC(M + 1) = IP IERR = 0 RETURN C C ERROR RETURN C 50 IERR = I RETURN END SUBROUTINE SSUBT (A,IA,JA,B,IB,JB,C,IC,JC,M,N,NUM,WK,IERR) C----------------------------------------------------------------------- C SUBTRACTION OF SPARSE REAL MATRICES C----------------------------------------------------------------------- REAL A(*), B(*), C(*), WK(N), T INTEGER IA(*), JA(*), IB(*), JB(*), IC(*), JC(*) C------------------------- DO 10 J = 1,N WK(J) = 0.0 10 CONTINUE C C COMPUTE THE I-TH ROW OF C C IP = 1 DO 42 I = 1,M IC(I) = IP MINA = IA(I) MAXA = IA(I+1) - 1 IF (MINA .GT. MAXA) GO TO 30 DO 20 L = MINA,MAXA J = JA(L) WK(J) = A(L) 20 CONTINUE C 30 MINB = IB(I) MAXB = IB(I+1) - 1 IF (MINB .GT. MAXB) GO TO 40 DO 31 L = MINB,MAXB J = JB(L) T = WK(J) - B(L) WK(J) = 0.0 IF (T .EQ. 0.0) GO TO 31 IF (IP .GT. NUM) GO TO 50 C(IP) = T JC(IP) = J IP = IP + 1 31 CONTINUE C 40 IF (MINA .GT. MAXA) GO TO 42 DO 41 L = MINA,MAXA J = JA(L) IF (WK(J) .EQ. 0.0) GO TO 41 IF (IP .GT. NUM) GO TO 50 C(IP) = WK(J) WK(J) = 0.0 JC(IP) = J IP = IP + 1 41 CONTINUE 42 CONTINUE IC(M + 1) = IP IERR = 0 RETURN C C ERROR RETURN C 50 IERR = I RETURN END SUBROUTINE DSSUBT (A,IA,JA,B,IB,JB,C,IC,JC,M,N,NUM,WK,IERR) C----------------------------------------------------------------------- C SUBTRACTION OF SPARSE DOUBLE PRECISION MATRICES C----------------------------------------------------------------------- DOUBLE PRECISION A(*), B(*), C(*), WK(N), T INTEGER IA(*), JA(*), IB(*), JB(*), IC(*), JC(*) C------------------------- DO 10 J = 1,N WK(J) = 0.D0 10 CONTINUE C C COMPUTE THE I-TH ROW OF C C IP = 1 DO 42 I = 1,M IC(I) = IP MINA = IA(I) MAXA = IA(I+1) - 1 IF (MINA .GT. MAXA) GO TO 30 DO 20 L = MINA,MAXA J = JA(L) WK(J) = A(L) 20 CONTINUE C 30 MINB = IB(I) MAXB = IB(I+1) - 1 IF (MINB .GT. MAXB) GO TO 40 DO 31 L = MINB,MAXB J = JB(L) T = WK(J) - B(L) WK(J) = 0.D0 IF (T .EQ. 0.D0) GO TO 31 IF (IP .GT. NUM) GO TO 50 C(IP) = T JC(IP) = J IP = IP + 1 31 CONTINUE C 40 IF (MINA .GT. MAXA) GO TO 42 DO 41 L = MINA,MAXA J = JA(L) IF (WK(J) .EQ. 0.D0) GO TO 41 IF (IP .GT. NUM) GO TO 50 C(IP) = WK(J) WK(J) = 0.D0 JC(IP) = J IP = IP + 1 41 CONTINUE 42 CONTINUE IC(M + 1) = IP IERR = 0 RETURN C C ERROR RETURN C 50 IERR = I RETURN END SUBROUTINE CSSUBT (A,IA,JA,B,IB,JB,C,IC,JC,M,N,NUM,WK,IERR) C----------------------------------------------------------------------- C SUBTRACTION OF SPARSE COMPLEX MATRICES C----------------------------------------------------------------------- COMPLEX A(*), B(*), C(*), WK(N), T INTEGER IA(*), JA(*), IB(*), JB(*), IC(*), JC(*) C------------------------- DO 10 J = 1,N WK(J) = (0.0, 0.0) 10 CONTINUE C C COMPUTE THE I-TH ROW OF C C IP = 1 DO 42 I = 1,M IC(I) = IP MINA = IA(I) MAXA = IA(I+1) - 1 IF (MINA .GT. MAXA) GO TO 30 DO 20 L = MINA,MAXA J = JA(L) WK(J) = A(L) 20 CONTINUE C 30 MINB = IB(I) MAXB = IB(I+1) - 1 IF (MINB .GT. MAXB) GO TO 40 DO 31 L = MINB,MAXB J = JB(L) T = WK(J) - B(L) WK(J) = (0.0, 0.0) IF (T .EQ. (0.0, 0.0)) GO TO 31 IF (IP .GT. NUM) GO TO 50 C(IP) = T JC(IP) = J IP = IP + 1 31 CONTINUE C 40 IF (MINA .GT. MAXA) GO TO 42 DO 41 L = MINA,MAXA J = JA(L) IF (WK(J) .EQ. (0.0, 0.0)) GO TO 41 IF (IP .GT. NUM) GO TO 50 C(IP) = WK(J) WK(J) = (0.0, 0.0) JC(IP) = J IP = IP + 1 41 CONTINUE 42 CONTINUE IC(M + 1) = IP IERR = 0 RETURN C C ERROR RETURN C 50 IERR = I RETURN END SUBROUTINE SPROD (A,IA,JA,B,IB,JB,C,IC,JC,L,M,N,NUM,WK,IERR) C----------------------------------------------------------------------- C MULTIPLICATION OF SPARSE REAL MATRICES C----------------------------------------------------------------------- REAL A(*), B(*), C(*), WK(N), T INTEGER IA(*), JA(*), IB(*), JB(*), IC(*), JC(*) C------------------------- DO 10 K = 1,N WK(K) = 0.0 10 CONTINUE C C COMPUTE THE I-TH ROW OF C C IP = 1 DO 31 I = 1,L IC(I) = IP JPMIN = IA(I) JPMAX = IA(I+1) - 1 IF (JPMIN .GT. JPMAX) GO TO 31 C DO 21 JP = JPMIN,JPMAX T = A(JP) IF (T .EQ. 0.0) GO TO 21 J = JA(JP) KPMIN = IB(J) KPMAX = IB(J+1) - 1 IF (KPMIN .GT. KPMAX) GO TO 21 DO 20 KP = KPMIN,KPMAX K = JB(KP) WK(K) = WK(K) + T*B(KP) 20 CONTINUE 21 CONTINUE C DO 30 K = 1,N IF (WK(K) .EQ. 0.0) GO TO 30 IF (IP .GT. NUM) GO TO 40 C(IP) = WK(K) WK(K) = 0.0 JC(IP) = K IP = IP + 1 30 CONTINUE 31 CONTINUE IC(L + 1) = IP IERR = 0 RETURN C C ERROR RETURN C 40 IERR = I RETURN END SUBROUTINE DSPROD (A,IA,JA,B,IB,JB,C,IC,JC,L,M,N,NUM,WK,IERR) C----------------------------------------------------------------------- C MULTIPLICATION OF SPARSE DOUBLE PRECISION MATRICES C----------------------------------------------------------------------- DOUBLE PRECISION A(*), B(*), C(*), WK(N), T INTEGER IA(*), JA(*), IB(*), JB(*), IC(*), JC(*) C------------------------- DO 10 K = 1,N WK(K) = 0.D0 10 CONTINUE C C COMPUTE THE I-TH ROW OF C C IP = 1 DO 31 I = 1,L IC(I) = IP JPMIN = IA(I) JPMAX = IA(I+1) - 1 IF (JPMIN .GT. JPMAX) GO TO 31 C DO 21 JP = JPMIN,JPMAX T = A(JP) IF (T .EQ. 0.D0) GO TO 21 J = JA(JP) KPMIN = IB(J) KPMAX = IB(J+1) - 1 IF (KPMIN .GT. KPMAX) GO TO 21 DO 20 KP = KPMIN,KPMAX K = JB(KP) WK(K) = WK(K) + T*B(KP) 20 CONTINUE 21 CONTINUE C DO 30 K = 1,N IF (WK(K) .EQ. 0.D0) GO TO 30 IF (IP .GT. NUM) GO TO 40 C(IP) = WK(K) WK(K) = 0.D0 JC(IP) = K IP = IP + 1 30 CONTINUE 31 CONTINUE IC(L + 1) = IP IERR = 0 RETURN C C ERROR RETURN C 40 IERR = I RETURN END SUBROUTINE CSPROD (A,IA,JA,B,IB,JB,C,IC,JC,L,M,N,NUM,WK,IERR) C----------------------------------------------------------------------- C MULTIPLICATION OF SPARSE COMPLEX MATRICES C----------------------------------------------------------------------- COMPLEX A(*), B(*), C(*), WK(N), T INTEGER IA(*), JA(*), IB(*), JB(*), IC(*), JC(*) C------------------------- DO 10 K = 1,N WK(K) = (0.0, 0.0) 10 CONTINUE C C COMPUTE THE I-TH ROW OF C C IP = 1 DO 31 I = 1,L IC(I) = IP JPMIN = IA(I) JPMAX = IA(I+1) - 1 IF (JPMIN .GT. JPMAX) GO TO 31 C DO 21 JP = JPMIN,JPMAX T = A(JP) IF (T .EQ. (0.0, 0.0)) GO TO 21 J = JA(JP) KPMIN = IB(J) KPMAX = IB(J+1) - 1 IF (KPMIN .GT. KPMAX) GO TO 21 DO 20 KP = KPMIN,KPMAX K = JB(KP) WK(K) = WK(K) + T*B(KP) 20 CONTINUE 21 CONTINUE C DO 30 K = 1,N IF (WK(K) .EQ. (0.0, 0.0)) GO TO 30 IF (IP .GT. NUM) GO TO 40 C(IP) = WK(K) WK(K) = (0.0, 0.0) JC(IP) = K IP = IP + 1 30 CONTINUE 31 CONTINUE IC(L + 1) = IP IERR = 0 RETURN C C ERROR RETURN C 40 IERR = I RETURN END SUBROUTINE MVPRD (M, N, A, IA, JA, X, Y) C----------------------------------------------------------------------- C PRODUCT OF A SPARSE MATRIX AND A VECTOR C----------------------------------------------------------------------- REAL A(*), X(N), Y(M), SUM INTEGER IA(*), JA(*) C DO 11 I = 1,M SUM = 0.0 LMIN = IA(I) LMAX = IA(I+1) - 1 IF (LMIN .GT. LMAX) GO TO 11 DO 10 L = LMIN,LMAX J = JA(L) SUM = SUM + A(L)*X(J) 10 CONTINUE 11 Y(I) = SUM RETURN END SUBROUTINE MVPRD1 (M, N, A, IA, JA, X, Y) C----------------------------------------------------------------------- C SET Y = A*X + Y WHERE A IS A SPARSE MATRIX AND X,Y ARE VECTORS C----------------------------------------------------------------------- REAL A(*), X(N), Y(M), SUM INTEGER IA(*), JA(*) C DO 11 I = 1,M SUM = Y(I) LMIN = IA(I) LMAX = IA(I+1) - 1 IF (LMIN .GT. LMAX) GO TO 11 DO 10 L = LMIN,LMAX J = JA(L) SUM = SUM + A(L)*X(J) 10 CONTINUE 11 Y(I) = SUM RETURN END SUBROUTINE MTPRD (M, N, A, IA, JA, X, Y) C----------------------------------------------------------------------- C PRODUCT OF A VECTOR AND A SPARSE MATRIX C----------------------------------------------------------------------- REAL A(*), X(M), Y(N), T INTEGER IA(*), JA(*) C DO 10 J = 1,N Y(J) = 0.0 10 CONTINUE C DO 21 I = 1,M T = X(I) LMIN = IA(I) LMAX = IA(I+1) - 1 IF (LMIN .GT. LMAX) GO TO 21 DO 20 L = LMIN,LMAX J = JA(L) Y(J) = Y(J) + T*A(L) 20 CONTINUE 21 CONTINUE RETURN END SUBROUTINE MTPRD1 (M, N, A, IA, JA, X, Y) C----------------------------------------------------------------------- C SET Y = X*A + Y WHERE A IS A SPARSE MATRIX AND X,Y ARE VECTORS C----------------------------------------------------------------------- REAL A(*), X(M), Y(N), T INTEGER IA(*), JA(*) C DO 11 I = 1,M T = X(I) LMIN = IA(I) LMAX = IA(I+1) - 1 IF (LMIN .GT. LMAX) GO TO 11 DO 10 L = LMIN,LMAX J = JA(L) Y(J) = Y(J) + T*A(L) 10 CONTINUE 11 CONTINUE RETURN END SUBROUTINE DVPRD (M, N, A, IA, JA, X, Y) C----------------------------------------------------------------------- C PRODUCT OF A SPARSE MATRIX AND A VECTOR C----------------------------------------------------------------------- DOUBLE PRECISION A(*), X(N), Y(M), SUM INTEGER IA(*), JA(*) C DO 11 I = 1,M SUM = 0.D0 LMIN = IA(I) LMAX = IA(I+1) - 1 IF (LMIN .GT. LMAX) GO TO 11 DO 10 L = LMIN,LMAX J = JA(L) SUM = SUM + A(L)*X(J) 10 CONTINUE 11 Y(I) = SUM RETURN END SUBROUTINE DVPRD1 (M, N, A, IA, JA, X, Y) C----------------------------------------------------------------------- C SET Y = A*X + Y WHERE A IS A SPARSE MATRIX AND X,Y ARE VECTORS C----------------------------------------------------------------------- DOUBLE PRECISION A(*), X(N), Y(M), SUM INTEGER IA(*), JA(*) C DO 11 I = 1,M SUM = Y(I) LMIN = IA(I) LMAX = IA(I+1) - 1 IF (LMIN .GT. LMAX) GO TO 11 DO 10 L = LMIN,LMAX J = JA(L) SUM = SUM + A(L)*X(J) 10 CONTINUE 11 Y(I) = SUM RETURN END SUBROUTINE DTPRD (M, N, A, IA, JA, X, Y) C----------------------------------------------------------------------- C PRODUCT OF A VECTOR AND A SPARSE MATRIX C----------------------------------------------------------------------- DOUBLE PRECISION A(*), X(M), Y(N), T INTEGER IA(*), JA(*) C DO 10 J = 1,N Y(J) = 0.D0 10 CONTINUE C DO 21 I = 1,M T = X(I) LMIN = IA(I) LMAX = IA(I+1) - 1 IF (LMIN .GT. LMAX) GO TO 21 DO 20 L = LMIN,LMAX J = JA(L) Y(J) = Y(J) + T*A(L) 20 CONTINUE 21 CONTINUE RETURN END SUBROUTINE DTPRD1 (M, N, A, IA, JA, X, Y) C----------------------------------------------------------------------- C SET Y = X*A + Y WHERE A IS A SPARSE MATRIX AND X,Y ARE VECTORS C----------------------------------------------------------------------- DOUBLE PRECISION A(*), X(M), Y(N), T INTEGER IA(*), JA(*) C DO 11 I = 1,M T = X(I) LMIN = IA(I) LMAX = IA(I+1) - 1 IF (LMIN .GT. LMAX) GO TO 11 DO 10 L = LMIN,LMAX J = JA(L) Y(J) = Y(J) + T*A(L) 10 CONTINUE 11 CONTINUE RETURN END SUBROUTINE CVPRD (M, N, A, IA, JA, X, Y) C----------------------------------------------------------------------- C PRODUCT OF A SPARSE MATRIX AND A VECTOR C----------------------------------------------------------------------- COMPLEX A(*), X(N), Y(M), SUM INTEGER IA(*), JA(*) C DO 11 I = 1,M SUM = (0.0, 0.0) LMIN = IA(I) LMAX = IA(I+1) - 1 IF (LMIN .GT. LMAX) GO TO 11 DO 10 L = LMIN,LMAX J = JA(L) SUM = SUM + A(L)*X(J) 10 CONTINUE 11 Y(I) = SUM RETURN END SUBROUTINE CVPRD1 (M, N, A, IA, JA, X, Y) C----------------------------------------------------------------------- C SET Y = A*X + Y WHERE A IS A SPARSE MATRIX AND X,Y ARE VECTORS C----------------------------------------------------------------------- COMPLEX A(*), X(N), Y(M), SUM INTEGER IA(*), JA(*) C DO 11 I = 1,M SUM = Y(I) LMIN = IA(I) LMAX = IA(I+1) - 1 IF (LMIN .GT. LMAX) GO TO 11 DO 10 L = LMIN,LMAX J = JA(L) SUM = SUM + A(L)*X(J) 10 CONTINUE 11 Y(I) = SUM RETURN END SUBROUTINE CTPRD (M, N, A, IA, JA, X, Y) C----------------------------------------------------------------------- C PRODUCT OF A VECTOR AND A SPARSE MATRIX C----------------------------------------------------------------------- COMPLEX A(*), X(M), Y(N), T INTEGER IA(*), JA(*) C DO 10 J = 1,N Y(J) = (0.0, 0.0) 10 CONTINUE C DO 21 I = 1,M T = X(I) LMIN = IA(I) LMAX = IA(I+1) - 1 IF (LMIN .GT. LMAX) GO TO 21 DO 20 L = LMIN,LMAX J = JA(L) Y(J) = Y(J) + T*A(L) 20 CONTINUE 21 CONTINUE RETURN END SUBROUTINE CTPRD1 (M, N, A, IA, JA, X, Y) C----------------------------------------------------------------------- C SET Y = X*A + Y WHERE A IS A SPARSE MATRIX AND X,Y ARE VECTORS C----------------------------------------------------------------------- COMPLEX A(*), X(M), Y(N), T INTEGER IA(*), JA(*) C DO 11 I = 1,M T = X(I) LMIN = IA(I) LMAX = IA(I+1) - 1 IF (LMIN .GT. LMAX) GO TO 11 DO 10 L = LMIN,LMAX J = JA(L) Y(J) = Y(J) + T*A(L) 10 CONTINUE 11 CONTINUE RETURN END REAL FUNCTION SNRM (A, IA, JA, M, N) C----------------------------------------------------------------------- C COMPUTATION OF THE L-INFINITY NORM OF A C REAL SPARSE MATRIX A C----------------------------------------------------------------------- REAL A(*) INTEGER IA(*), JA(*) C SNRM = 0.0 DO 20 I = 1,M IPMIN = IA(I) IPMAX = IA(I + 1) - 1 IF (IPMIN .GT. IPMAX) GO TO 20 SUM = 0.0 DO 10 IP = IPMIN,IPMAX SUM = SUM + ABS(A(IP)) 10 CONTINUE SNRM = AMAX1(SNRM, SUM) 20 CONTINUE RETURN END SUBROUTINE S1NRM (A, IA, JA, M, N, ANORM, WK) C----------------------------------------------------------------------- C COMPUTATION OF THE L1 NORM OF A REAL SPARSE MATRIX A C----------------------------------------------------------------------- REAL A(*), WK(N) INTEGER IA(*), JA(*) C ANORM = 0.0 IPMIN = IA(1) IPMAX = IA(M + 1) - 1 IF (IPMIN .GT. IPMAX) RETURN C C COMPUTE THE L1 NORM OF A C DO 10 J = 1,N WK(J) = 0.0 10 CONTINUE C DO 20 IP = IPMIN,IPMAX J = JA(IP) WK(J) = WK(J) + ABS(A(IP)) 20 CONTINUE C DO 30 J = 1,N ANORM = AMAX1(ANORM,WK(J)) 30 CONTINUE RETURN END DOUBLE PRECISION FUNCTION DSNRM (A, IA, JA, M, N) C----------------------------------------------------------------------- C COMPUTATION OF THE L-INFINITY NORM OF A C DOUBLE PRECISION SPARSE MATRIX A C----------------------------------------------------------------------- DOUBLE PRECISION A(*), SUM INTEGER IA(*), JA(*) C DSNRM = 0.D0 DO 20 I = 1,M IPMIN = IA(I) IPMAX = IA(I + 1) - 1 IF (IPMIN .GT. IPMAX) GO TO 20 SUM = 0.D0 DO 10 IP = IPMIN,IPMAX SUM = SUM + DABS(A(IP)) 10 CONTINUE DSNRM = DMAX1(DSNRM, SUM) 20 CONTINUE RETURN END SUBROUTINE DS1NRM (A, IA, JA, M, N, ANORM, WK) C----------------------------------------------------------------------- C COMPUTATION OF THE L1 NORM OF A SPARSE C DOUBLE PRECISION MATRIX A C----------------------------------------------------------------------- DOUBLE PRECISION A(*), ANORM, WK(N) INTEGER IA(*), JA(*) C ANORM = 0.D0 IPMIN = IA(1) IPMAX = IA(M + 1) - 1 IF (IPMIN .GT. IPMAX) RETURN C C COMPUTE THE L1 NORM OF A C DO 10 J = 1,N WK(J) = 0.D0 10 CONTINUE C DO 20 IP = IPMIN,IPMAX J = JA(IP) WK(J) = WK(J) + DABS(A(IP)) 20 CONTINUE C DO 30 J = 1,N ANORM = DMAX1(ANORM,WK(J)) 30 CONTINUE RETURN END SUBROUTINE SPORD (M, N, IA, R, IWK) C----------------------------------------------------------------------- C SPORD ORDERS THE ROWS OF AN MXN SPARSE MATRIX A,IA,JA C BY INCREASING LENGTH. THE ROW ORDERING IS GIVEN IN R. C----------------------------------------------------------------------- C IWK IS A WORK SPACE OF DIMENSION M + N + 1. C---------------------- INTEGER IA(*), R(M), IWK(*) C NP1 = N + 1 DO 10 I = 1,NP1 IWK(I) = 0 10 CONTINUE C I = M DO 20 II = 1,M NUM = IA(I+1) - IA(I) + 1 L = NP1 + I IWK(L) = IWK(NUM) IWK(NUM) = I I = I - 1 20 CONTINUE C NUM = 1 K = IWK(NUM) DO 32 I = 1,M 30 IF (K .NE. 0) GO TO 31 NUM = NUM + 1 K = IWK(NUM) GO TO 30 31 R(I) = K L = NP1 + K K = IWK(L) 32 CONTINUE RETURN END SUBROUTINE BLKORD (N, IA, JA, R, C, IB, NUM, IWK, IERR) C----------------------------------------------------------------------- C REORDERING A SPARSE MATRIX INTO BLOCK TRIANGULAR FORM C----------------------------------------------------------------------- INTEGER IA(*), JA(*), R(N), C(N), IB(N) C INTEGER IWK(5*N) INTEGER IWK(*) C NP1 = N + 1 LENGTH = IA(NP1) - IA(1) DO 10 I = 1,N IWK(I) = IA(I+1) - IA(I) 10 CONTINUE CALL MC21A(N,JA,LENGTH,IA,IWK(1),R,NUM,IWK(NP1)) IERR = N - NUM IF (IERR .NE. 0) RETURN C DO 20 I = 1,N LI = R(I) IWK(I) = IA(LI) NPI = N + I IWK(NPI) = IA(LI+1) - IA(LI) 20 CONTINUE CALL MC13D(N,JA,LENGTH,IWK(1),IWK(NP1),C,IB,NUM,IWK(2*N+1)) C DO 30 I = 1,N LI = C(I) IWK(I) = R(LI) 30 CONTINUE DO 31 I = 1,N R(I) = IWK(I) 31 CONTINUE RETURN END SUBROUTINE MC21A (N,ICN,LICN,IP,LENR,IPERM,NUMNZ,IW) C----------------------------------------------------------------------- C DESCRIPTION OF PARAMETERS. C INPUT VARIABLES N,ICN,LICN,IP,LENR C OUTPUT VARIABLES IPERM,NUMNZ C C N ORDER OF MATRIX. C ICN ARRAY CONTAINING THE COLUMN INDICES OF THE NON-ZEROS. THOSE C BELONGING TO A SINGLE ROW MUST BE CONTIGUOUS BUT THE ORDERING C OF COLUMN INDICES WITHIN EACH ROW IS UNIMPORTANT AND WASTED C SPACE BETWEEN ROWS IS PERMITTED. C LICN LENGTH OF ARRAY ICN. C IP IP(I), I=1,2,...N, IS THE POSITION IN ARRAY ICN OF THE FIRST C COLUMN INDEX OF A NON-ZERO IN ROW I. C LENR LENR(I) IS THE NUMBER OF NON-ZEROS IN ROW I, I=1,2,..N. C IPERM CONTAINS PERMUTATION TO MAKE DIAGONAL HAVE THE SMALLEST C NUMBER OF ZEROS ON IT. ELEMENTS (IPERM(I),I) I=1, ... N ARE C NON-ZERO AT THE END OF THE ALGORITHM UNLESS MATRIX C IS STRUCTURALLY SINGULAR. IN THIS CASE, (IPERM(I),I) WILL C BE ZERO FOR N-NUMNZ ENTRIES. C NUMNZ NUMBER OF NON-ZEROS ON DIAGONAL OF PERMUTED MATRIX. C IW WORK ARRAY .. SEE LATER COMMENTS. C----------------------------------------------------------------------- INTEGER IP(N) INTEGER ICN(LICN), LENR(N), IPERM(N), IW(N,4) C CALL MC21B (N,ICN,LICN,IP,LENR,IPERM,NUMNZ,IW(1,1),IW(1,2), * IW(1,3),IW(1,4)) RETURN END SUBROUTINE MC21B (N,ICN,LICN,IP,LENR,IPERM,NUMNZ,PR,ARP,CV,OUT) C----------------------------------------------------------------------- C DIVISION OF WORK ARRAY IS NOW DESCRIBED. C C PR(I) IS THE PREVIOUS ROW TO I IN THE DEPTH FIRST SEARCH. C ARP(I) IS ONE LESS THAN THE NUMBER OF NON-ZEROS IN ROW I C WHICH HAVE NOT BEEN SCANNED WHEN LOOKING FOR A CHEAP ASSIGNMENT. C CV(I) IS THE MOST RECENT ROW EXTENSION AT WHICH COLUMN I C WAS VISITED. C OUT(I) IS ONE LESS THAN THE NUMBER OF NON-ZEROS IN ROW I C WHICH HAVE NOT BEEN SCANNED DURING ONE PASS THROUGH THE C MAIN LOOP. C----------------------------------------------------------------------- INTEGER IP(N), ICN(LICN), LENR(N), IPERM(N), PR(N), CV(N), * ARP(N), OUT(N) C C INITIALIZATION OF ARRAYS C DO 10 I = 1,N ARP(I) = LENR(I) - 1 CV(I) = 0 IPERM(I) = 0 10 CONTINUE NUMNZ = 0 C C MAIN LOOP. C EACH PASS ROUND THIS LOOP EITHER RESULTS IN A NEW ASSIGNMENT C OR GIVES A ROW WITH NO ASSIGNMENT. C DO 130 JORD = 1,N J = JORD PR(J) = -1 DO 100 K = 1,JORD C C LOOK FOR A CHEAP ASSIGNMENT C IN1 = ARP(J) IF (IN1 .LT. 0) GO TO 60 IN2 = IP(J) + LENR(J) - 1 IN1 = IN2 - IN1 DO 50 II = IN1,IN2 I = ICN(II) IF (IPERM(I) .EQ. 0) GO TO 110 50 CONTINUE C C NO CHEAP ASSIGNMENT IN ROW C ARP(J) = -1 C C BEGIN LOOKING FOR ASSIGNMENT CHAIN STARTING WITH ROW J C 60 OUT(J) = LENR(J) - 1 C C INNER LOOP. EXTENDS CHAIN BY ONE OR BACKTRACKS. C DO 90 KK = 1,JORD IN1 = OUT(J) IF (IN1 .LT. 0) GO TO 80 IN2 = IP(J) + LENR(J) - 1 IN1 = IN2 - IN1 C C FORWARD SCAN C DO 70 II = IN1,IN2 I = ICN(II) IF (CV(I) .EQ. JORD) GO TO 70 C C COLUMN I HAS NOT YET BEEN ACCESSED DURING THIS PASS C J1 = J J = IPERM(I) CV(I) = JORD PR(J) = J1 OUT(J1) = IN2 - II - 1 GO TO 100 70 CONTINUE C C BACKTRACKING STEP C 80 J = PR(J) IF (J .EQ. -1) GO TO 130 90 CONTINUE C 100 CONTINUE C C NEW ASSIGNMENT IS MADE C 110 IPERM(I) = J ARP(J) = IN2 - II - 1 NUMNZ = NUMNZ + 1 DO 120 K = 1,JORD J = PR(J) IF (J .EQ. -1) GO TO 130 II = IP(J) + LENR(J) - OUT(J) - 2 I = ICN(II) IPERM(I) = J 120 CONTINUE C 130 CONTINUE C C IF MATRIX IS STRUCTURALLY SINGULAR, WE NOW COMPLETE THE C PERMUTATION IPERM. C IF (NUMNZ .EQ. N) GO TO 500 DO 140 I = 1,N ARP(I) = 0 140 CONTINUE K = 0 DO 160 I = 1,N IF (IPERM(I) .NE. 0) GO TO 150 K = K + 1 OUT(K) = I GO TO 160 150 J = IPERM(I) ARP(J) = I 160 CONTINUE K = 0 DO 170 I = 1,N IF (ARP(I) .NE. 0) GO TO 170 K = K + 1 IOUTK = OUT(K) IPERM(IOUTK) = I 170 CONTINUE 500 RETURN END SUBROUTINE MC13D(N, ICN, LICN, IP, LENR, IOR, IB, NUM, IW) C C DESCRIPTION OF PARAMETERS. C INPUT VARIABLES .... N,ICN,LICN,IP,LENR. C OUTPUT VARIABLES IOR,IB,NUM. C C N ORDER OF THE MATRIX. C ICN ARRAY CONTAINING THE COLUMN INDICES OF THE NON-ZEROS. THOSE C BELONGING TO A SINGLE ROW MUST BE CONTIGUOUS BUT THE ORDERING C OF COLUMN INDICES WITHIN EACH ROW IS UNIMPORTANT AND WASTED C SPACE BETWEEN ROWS IS PERMITTED. C LICN LENGTH OF ARRAY ICN. C IP IP(I), I=1,2,...N, IS THE POSITION IN ARRAY ICN OF THE FIRST C COLUMN INDEX OF A NON-ZERO IN ROW I. C LENR LENR(I) IS THE NUMBER OF NON-ZEROS IN ROW I, I=1,2,...N. C IOR IOR(I) GIVES THE POSITION IN THE ORIGINAL ORDERING OF THE ROW C OR COLUMN WHICH IS IN POSITION I IN THE PERMUTED FORM, I=1,2,..N. C IB IB(I) IS THE ROW NUMBER IN THE PERMUTED MATRIX OF THE BEGINNING C OF BLOCK I, I=1,2,...NUM. C NUM NUMBER OF BLOCKS FOUND. C IW WORK ARRAY OF LENGTH 3*N. C INTEGER IP(N) INTEGER ICN(LICN), LENR(N), IOR(N), IB(N), IW(N,3) C CALL MC13E(N, ICN, LICN, IP, LENR, IOR, IB, NUM, IW(1,1), * IW(1,2), IW(1,3)) RETURN END SUBROUTINE MC13E(N, ICN, LICN, IP, LENR, ARP, IB, NUM, LOWL, * NUMB, PREV) INTEGER STP, DUMMY INTEGER IP(N) C C ARP(I) IS ONE LESS THAN THE NUMBER OF UNSEARCHED EDGES LEAVING C NODE I. AT THE END OF THE ALGORITHM IT IS SET TO A C PERMUTATION WHICH PUTS THE MATRIX IN BLOCK LOWER C TRIANGULAR FORM. C IB(I) IS THE POSITION IN THE ORDERING OF THE START OF THE ITH C BLOCK. IB(N+1-I) HOLDS THE NODE NUMBER OF THE ITH NODE C ON THE STACK. C LOWL(I) IS THE SMALLEST STACK POSITION OF ANY NODE TO WHICH A PATH C FROM NODE I HAS BEEN FOUND. IT IS SET TO N+1 WHEN NODE I C IS REMOVED FROM THE STACK. C NUMB(I) IS THE POSITION OF NODE I IN THE STACK IF IT IS ON C IT, IS THE PERMUTED ORDER OF NODE I FOR THOSE NODES C WHOSE FINAL POSITION HAS BEEN FOUND AND IS OTHERWISE ZERO. C PREV(I) IS THE NODE AT THE END OF THE PATH WHEN NODE I WAS C PLACED ON THE STACK. C INTEGER ICN(LICN), LENR(N), ARP(N), IB(N), LOWL(N), NUMB(N), * PREV(N) C C ICNT IS THE NUMBER OF NODES WHOSE POSITIONS IN FINAL ORDERING HAVE C BEEN FOUND. C ICNT = 0 C NUM IS THE NUMBER OF BLOCKS THAT HAVE BEEN FOUND. NUM = 0 NNM1 = N + N - 1 C C INITIALIZATION OF ARRAYS. C DO 10 J=1,N NUMB(J) = 0 ARP(J) = LENR(J) - 1 10 CONTINUE C C DO 90 ISN=1,N C LOOK FOR A STARTING NODE IF (NUMB(ISN).NE.0) GO TO 90 IV = ISN C IST IS THE NUMBER OF NODES ON THE STACK ... IT IS THE STACK POINTER. IST = 1 C PUT NODE IV AT BEGINNING OF STACK. LOWL(IV) = 1 NUMB(IV) = 1 IB(N) = IV C C THE BODY OF THIS LOOP PUTS A NEW NODE ON THE STACK OR BACKTRACKS. C DO 80 DUMMY=1,NNM1 I1 = ARP(IV) C HAVE ALL EDGES LEAVING NODE IV BEEN SEARCHED. IF (I1.LT.0) GO TO 30 I2 = IP(IV) + LENR(IV) - 1 I1 = I2 - I1 C C LOOK AT EDGES LEAVING NODE IV UNTIL ONE ENTERS A NEW NODE OR C ALL EDGES ARE EXHAUSTED. C DO 20 II=I1,I2 IW = ICN(II) C HAS NODE IW BEEN ON STACK ALREADY. IF (NUMB(IW).EQ.0) GO TO 70 C UPDATE VALUE OF LOWL(IV) IF NECESSARY. IF (LOWL(IW).LT.LOWL(IV)) LOWL(IV) = LOWL(IW) 20 CONTINUE C C THERE ARE NO MORE EDGES LEAVING NODE IV. C ARP(IV) = -1 C IS NODE IV THE ROOT OF A BLOCK. 30 IF (LOWL(IV).LT.NUMB(IV)) GO TO 60 C C ORDER NODES IN A BLOCK. C NUM = NUM + 1 IST1 = N + 1 - IST LCNT = ICNT + 1 C C PEEL BLOCK OFF THE TOP OF THE STACK STARTING AT THE TOP AND C WORKING DOWN TO THE ROOT OF THE BLOCK. C DO 40 STP=IST1,N IW = IB(STP) LOWL(IW) = N + 1 ICNT = ICNT + 1 NUMB(IW) = ICNT IF (IW.EQ.IV) GO TO 50 40 CONTINUE 50 IST = N - STP IB(NUM) = LCNT C ARE THERE ANY NODES LEFT ON THE STACK. IF (IST.NE.0) GO TO 60 C HAVE ALL THE NODES BEEN ORDERED. IF (ICNT.LT.N) GO TO 90 GO TO 100 C C BACKTRACK TO PREVIOUS NODE ON PATH. C 60 IW = IV IV = PREV(IV) C UPDATE VALUE OF LOWL(IV) IF NECESSARY. IF (LOWL(IW).LT.LOWL(IV)) LOWL(IV) = LOWL(IW) GO TO 80 C C PUT NEW NODE ON THE STACK. C 70 ARP(IV) = I2 - II - 1 PREV(IW) = IV IV = IW IST = IST + 1 LOWL(IV) = IST NUMB(IV) = IST K = N + 1 - IST IB(K) = IV 80 CONTINUE C 90 CONTINUE C C PUT PERMUTATION IN THE REQUIRED FORM. C 100 DO 110 I=1,N II = NUMB(I) ARP(II) = I 110 CONTINUE RETURN END SUBROUTINE SPSLV (N,A,IA,JA,B,R,C,MAX,X,ITEMP,RTEMP,IERR) C----------------------------------------------------------------------- C SOLUTION OF REAL SPARSE EQUATIONS C----------------------------------------------------------------------- C SPSLV CALLS NSPIV1 WHICH USES SPARSE GAUSSIAN ELIMINATION WITH C COLUMN INTERCHANGES TO SOLVE THE LINEAR SYSTEM A X = B. THE C ELIMINATION PHASE PERFORMS ROW OPERATIONS ON A AND B TO OBTAIN C A UNIT UPPER TRIANGULAR MATRIX U AND A VECTOR Y. THE SOLUTION C PHASE SOLVES U X = Y. C C INPUT ARGUMENTS--- C C N INTEGER NUMBER OF EQUATIONS AND UNKNOWNS C C A REAL ARRAY WITH ONE ENTRY PER NONZERO IN A, CONTAINING THE C ACTUAL NONZEROS. (SEE MATRIX STORAGE DESCRIPTION BELOW) C C IA INTEGER ARRAY OF N+1 ENTRIES CONTAINING ROW POINTERS TO A C (SEE MATRIX STORAGE DESCRIPTION BELOW) C C JA INTEGER ARRAY WITH ONE ENTRY PER NONZERO IN A, CONTAINING C COLUMN NUMBERS OF THE NONZEROS OF A. (SEE MATRIX STORAGE C DESCRIPTION BELOW) C C B REAL ARRAY OF N ENTRIES CONTAINING RIGHT HAND SIDE DATA C C R INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF THE C ROWS OF A (I.E., THE ELIMINATION ORDER FOR THE EQUATIONS) C C C INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF THE C COLUMNS OF A. C IS ALSO AN OUTPUT ARGUMENT C C MAX INTEGER NUMBER SPECIFYING MAXIMUM NUMBER OF OFF-DIAGONAL C NONZERO ENTRIES OF U WHICH MAY BE STORED C C ITEMP INTEGER ARRAY OF 3*N + MAX + 2 ENTRIES, FOR INTERNAL USE C C RTEMP REAL ARRAY OF N + MAX ENTRIES FOR INTERNAL USE C C C OUTPUT ARGUMENTS--- C C C INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF THE C COLUMNS OF U. C IS ALSO AN INPUT ARGUMENT C C X REAL ARRAY OF N ENTRIES CONTAINING THE SOLUTION VECTOR C C IERR INTEGER NUMBER WHICH INDICATES ERROR CONDITIONS OR C THE ACTUAL NUMBER OF OFF-DIAGONAL ENTRIES IN U (FOR C SUCCESSFUL COMPLETION) C C IERR VALUES ARE--- C C 0 LT IERR SUCCESSFUL COMPLETION. IERR=MAX(1,M) C WHERE M IS THE NUMBER OF OFF-DIAGONAL C NONZERO ENTRIES OF U. C C IERR = 0 ERROR. N IS LESS THAN OR EQUAL TO 0 C C -N LE IERR LT 0 ERROR. ROW NUMBER IABS(IERR) OF A IS C IS NULL C C -2*N LE IERR LT -N ERROR. ROW NUMBER IABS(IERR+N) HAS A C DUPLICATE ENTRY C C -3*N LE IERR LT -2*N ERROR. ROW NUMBER IABS(IERR+2*N) C HAS A ZERO PIVOT C C -4*N LE IERR LT -3*N ERROR. ROW NUMBER IABS(IERR+3*N) C EXCEEDS STORAGE C C C STORAGE OF SPARSE MATRICES--- C C THE SPARSE MATRIX A IS STORED USING THREE ARRAYS IA, JA, AND A. C THE ARRAY A CONTAINS THE NONZEROS OF THE MATRIX ROW-BY-ROW, NOT C NECESSARILY IN ORDER OF INCREASING COLUMN NUMBER. THE ARRAY JA C CONTAINS THE COLUMN NUMBERS CORRESPONDING TO THE NONZEROS STORED C IN THE ARRAY A (I.E., IF THE NONZERO STORED IN A(K) IS IN C COLUMN J, THEN JA(K) = J). THE ARRAY IA CONTAINS POINTERS TO THE C ROWS OF NONZEROS/COLUMN INDICES IN THE ARRAY A/JA (I.E., C A(IA(I))/JA(IA(I)) IS THE FIRST ENTRY FOR ROW I IN THE ARRAY A/JA). C IA(N+1) IS SET SO THAT IA(N+1) - IA(1) = THE NUMBER OF NONZERO C ELEMENTS IN A. C------------------------ REAL A(*), B(N), X(N), RTEMP(*) INTEGER IA(*), JA(*), R(N), C(N), ITEMP(*) INTEGER IU, JU, U, Y, P C IERR = 0 IF (N .LE. 0) RETURN C C SET INDICES TO DIVIDE TEMPORARY STORAGE FOR NSPIV1 C Y = 1 U = Y + N P = N + 1 IU = P + N + 1 JU = IU + N + 1 C C COMPUTE THE INVERSE PERMUTATION OF C C DO 10 K = 1,N L = C(K) ITEMP(L) = K 10 CONTINUE C C CALL NSPIV1 TO PERFORM COMPUTATIONS C CALL NSPIV1 (N,IA,JA,A,B,MAX,R,C,ITEMP(1),X,RTEMP(Y),ITEMP(P), * ITEMP(IU),ITEMP(JU),RTEMP(U),IERR) IF (IERR .EQ. 0) IERR = 1 RETURN END SUBROUTINE NSPIV1 (N,IA,JA,A,B,MAX,R,C,IC,X,Y,P,IU,JU,U,IERR) C C C NSPIV1 USES SPARSE GAUSSIAN ELIMINATION WITH C COLUMN INTERCHANGES TO SOLVE THE LINEAR SYSTEM A X = B. THE C ELIMINATION PHASE PERFORMS ROW OPERATIONS ON A AND B TO OBTAIN C A UNIT UPPER TRIANGULAR MATRIX U AND A VECTOR Y. THE SOLUTION C PHASE SOLVES U X = Y. C C C SEE SPSLV FOR DESCRIPTIONS OF ALL INPUT AND OUTPUT ARGUMENTS C OTHER THAN THOSE DESCRIBED BELOW C C IC INTEGER ARRAY OF N ENTRIES WHICH IS THE INVERSE OF C C (I.E., IC(C(I)) = I). IC IS BOTH AN INPUT AND OUTPUT C ARGUMENT. C C INPUT ARGUMENTS (USED INTERNALLY ONLY)--- C C Y REAL ARRAY OF N ENTRIES USED TO COMPUTE THE UPDATED C RIGHT HAND SIDE C C P INTEGER ARRAY OF N+1 ENTRIES USED FOR A LINKED LIST. C P(N+1) IS THE LIST HEADER, AND THE ENTRY FOLLOWING C P(K) IS IN P(P(K)). THUS, P(N+1) IS THE FIRST DATA C ITEM, P(P(N+1)) IS THE SECOND, ETC. A POINTER OF C N+1 MARKS THE END OF THE LIST C C IU INTEGER ARRAY OF N+1 ENTRIES USED FOR ROW POINTERS TO U C (SEE MATRIX STORAGE DESCRIPTION BELOW) C C JU INTEGER ARRAY OF MAX ENTRIES USED FOR COLUMN NUMBERS OF C THE NONZEROS IN THE STRICT UPPER TRIANGLE OF U. (SEE C MATRIX STORAGE DESCRIPTION BELOW) C C U REAL ARRAY OF MAX ENTRIES USED FOR THE ACTUAL NONZEROS IN C THE STRICT UPPER TRIANGLE OF U. (SEE MATRIX STORAGE C DESCRIPTION BELOW) C C C STORAGE OF SPARSE MATRICES--- C C THE SPARSE MATRIX A IS STORED USING THREE ARRAYS IA, JA, AND A. C THE ARRAY A CONTAINS THE NONZEROS OF THE MATRIX ROW-BY-ROW, NOT C NECESSARILY IN ORDER OF INCREASING COLUMN NUMBER. THE ARRAY JA C CONTAINS THE COLUMN NUMBERS CORRESPONDING TO THE NONZEROS STORED C IN THE ARRAY A (I.E., IF THE NONZERO STORED IN A(K) IS IN C COLUMN J, THEN JA(K) = J). THE ARRAY IA CONTAINS POINTERS TO THE C ROWS OF NONZEROS/COLUMN INDICES IN THE ARRAY A/JA (I.E., C A(IA(I))/JA(IA(I)) IS THE FIRST ENTRY FOR ROW I IN THE ARRAY A/JA). C IA(N+1) IS SET SO THAT IA(N+1) - IA(1) = THE NUMBER OF NONZEROS IN C A. IU, JU, AND U ARE USED IN A SIMILAR WAY TO STORE THE STRICT UPPER C TRIANGLE OF U, EXCEPT THAT JU ACTUALLY CONTAINS C(J) INSTEAD OF J C C REAL A(*), B(N), U(MAX), X(N), Y(N) REAL DK, LKI, XPV, XPVMAX, YK INTEGER C(N), IA(*), IC(N), IU(*), JA(*), JU(MAX), P(*), R(N) INTEGER CK, PK, PPK, PV, V, VI, VJ, VK C C INITIALIZE WORK STORAGE AND POINTERS TO JU C DO 10 J = 1,N X(J) = 0.0 10 CONTINUE IU(1) = 1 JUPTR = 0 C C PERFORM SYMBOLIC AND NUMERIC FACTORIZATION ROW BY ROW C VK (VI,VJ) IS THE GRAPH VERTEX FOR ROW K (I,J) OF U C DO 170 K = 1,N C C INITIALIZE LINKED LIST AND FREE STORAGE FOR THIS ROW C THE R(K)-TH ROW OF A BECOMES THE K-TH ROW OF U. C P(N+1) = N+1 VK = R(K) C C SET UP ADJACENCY LIST FOR VK, ORDERED IN C CURRENT COLUMN ORDER OF U. THE LOOP INDEX C GOES DOWNWARD TO EXPLOIT ANY COLUMNS C FROM A IN CORRECT RELATIVE ORDER C JMIN = IA(VK) JMAX = IA(VK+1) - 1 IF (JMIN .GT. JMAX) GO TO 1002 J = JMAX 20 JAJ = JA(J) VJ = IC(JAJ) C C STORE A(K,J) IN WORK VECTOR C X(VJ) = A(J) C THIS CODE INSERTS VJ INTO ADJACENCY LIST OF VK PPK = N+1 30 PK = PPK PPK = P(PK) IF (PPK - VJ) 30,1003,40 40 P(VJ) = PPK P(PK) = VJ J = J - 1 IF (J .GE. JMIN) GO TO 20 C C THE FOLLOWING CODE COMPUTES THE K-TH ROW OF U C VI = N+1 YK = B(VK) 50 VI = P(VI) IF (VI .GE. K) GO TO 110 C C VI LT VK -- PROCESS THE L(K,I) ELEMENT AND MERGE THE C ADJACENCY OF VI WITH THE ORDERED ADJACENCY OF VK C LKI = - X(VI) X(VI) = 0.0 C C ADJUST RIGHT HAND SIDE TO REFLECT ELIMINATION C YK = YK + LKI * Y(VI) PPK = VI JMIN = IU(VI) JMAX = IU(VI+1) - 1 IF (JMIN .GT. JMAX) GO TO 50 DO 100 J = JMIN,JMAX JUJ = JU(J) VJ = IC(JUJ) C C IF VJ IS ALREADY IN THE ADJACENCY OF VK, C SKIP THE INSERTION C IF (X(VJ) .NE. 0.0) GO TO 90 C C INSERT VJ IN ADJACENCY LIST OF VK. C RESET PPK TO VI IF WE HAVE PASSED THE CORRECT C INSERTION SPOT. (THIS HAPPENS WHEN THE ADJACENCY OF C VI IS NOT IN CURRENT COLUMN ORDER DUE TO PIVOTING.) C IF (VJ - PPK) 60,90,70 60 PPK = VI 70 PK = PPK PPK = P(PK) IF (PPK - VJ) 70,90,80 80 P(VJ) = PPK P(PK) = VJ PPK = VJ C C COMPUTE L(K,J) = L(K,J) - L(K,I)*U(I,J) FOR L(K,I) NONZERO C COMPUTE U*(K,J) = U*(K,J) - L(K,I)*U(I,J) FOR U(K,J) NONZERO C (U*(K,J) = U(K,J)*D(K,K)) C 90 X(VJ) = X(VJ) + LKI * U(J) 100 CONTINUE GO TO 50 C C PIVOT--INTERCHANGE LARGEST ENTRY OF K-TH ROW OF U WITH C THE DIAGONAL ENTRY. C C FIND LARGEST ENTRY, COUNTING OFF-DIAGONAL NONZEROS C 110 IF (VI .GT. N) GO TO 1004 XPVMAX = ABS(X(VI)) MAXC = VI NZCNT = 0 PV = VI 120 V = PV PV = P(PV) IF (PV .GT. N) GO TO 130 NZCNT = NZCNT + 1 XPV = ABS(X(PV)) IF (XPV .LE. XPVMAX) GO TO 120 XPVMAX = XPV MAXC = PV MAXCL = V GO TO 120 130 IF (XPVMAX .EQ. 0.0) GO TO 1004 C C IF VI = K, THEN THERE IS AN ENTRY FOR DIAGONAL C WHICH MUST BE DELETED. OTHERWISE, DELETE THE C ENTRY WHICH WILL BECOME THE DIAGONAL ENTRY C IF (VI .EQ. K) GO TO 140 IF (VI .EQ. MAXC) GO TO 140 P(MAXCL) = P(MAXC) GO TO 150 140 VI = P(VI) C C COMPUTE D(K) = 1/L(K,K) AND PERFORM INTERCHANGE. C 150 DK = 1.0 / X(MAXC) X(MAXC) = X(K) I = C(K) C(K) = C(MAXC) C(MAXC) = I CK = C(K) IC(CK) = K IC(I) = MAXC X(K) = 0.0 C C UPDATE RIGHT HAND SIDE. C Y(K) = YK * DK C C COMPUTE VALUE FOR IU(K+1) AND CHECK FOR STORAGE OVERFLOW C IU(K+1) = IU(K) + NZCNT IF (IU(K+1) .GT. MAX+1) GO TO 1005 C C MOVE COLUMN INDICES FROM LINKED LIST TO JU. C COLUMNS ARE STORED IN CURRENT ORDER WITH ORIGINAL C COLUMN NUMBER (C(J)) STORED FOR CURRENT COLUMN J C IF (VI .GT. N) GO TO 170 J = VI 160 JUPTR = JUPTR + 1 JU(JUPTR) = C(J) U(JUPTR) = X(J) * DK X(J) = 0.0 J = P(J) IF (J .LE. N) GO TO 160 170 CONTINUE C C BACKSOLVE U X = Y, AND REORDER X TO CORRESPOND WITH A C K = N DO 200 I = 1,N YK = Y(K) JMIN = IU(K) JMAX = IU(K+1) - 1 IF (JMIN .GT. JMAX) GO TO 190 DO 180 J = JMIN,JMAX JUJ = JU(J) JUJ = IC(JUJ) YK = YK - U(J) * Y(JUJ) 180 CONTINUE 190 Y(K) = YK CK = C(K) X(CK) = YK K = K - 1 200 CONTINUE C C RETURN WITH IERR = NUMBER OF OFF-DIAGONAL NONZEROS IN U C IERR = IU(N+1) - IU(1) RETURN C C ERROR RETURNS C C ROW K OF A IS NULL C 1002 IERR = -K RETURN C C ROW K OF A HAS A DUPLICATE ENTRY C 1003 IERR = -(N+K) RETURN C C ZERO PIVOT IN ROW K C 1004 IERR = -(2*N+K) RETURN C C STORAGE FOR U EXCEEDED ON ROW K C 1005 IERR = -(3*N+K) RETURN END SUBROUTINE RSLV (M0,N,A,IA,JA,B,R,C,MAX,X,IWK,WK,IERR) C----------------------------------------------------------------------- C SOLUTION OF REAL SPARSE EQUATIONS C----------------------------------------------------------------------- C RSLV EMPLOYS GAUSSIAN ELIMINATION WITH COLUMN INTERCHANGES TO C SOLVE THE NXN LINEAR SYSTEM AX = B. THE ARGUMENT M0 SPECIFIES C IF RSLV IS BEING CALLED FOR THE FIRST TIME, OR IF IT IS BEING C RECALLED WHERE A IS THE SAME MATRIX BUT B HAS BEEN MODIFIED. C ON AN INITIAL CALL TO THE ROUTINE (WHEN M0=0) THE LU DECOMPO- C SITION OF A IS OBTAINED WHERE U IS A UNIT UPPER TRIANGULAR C MATRIX. THEN THE EQUATIONS ARE SOLVED. ON SUBSEQUENT CALLS C (WHEN M0.NE.0) THE EQUATIONS ARE SOLVED USING THE DECOMPOSITION C OBTAINED ON THE INITIAL CALL TO RSLV. C C C INPUT ARGUMENTS WHEN M0=0 --- C C N NUMBER OF EQUATIONS AND UNKNOWNS. C C A,IA,JA THE MATRIX A STORED IN SPARSE FORM. C C B ARRAY OF N ENTRIES CONTAINING THE RIGHT HAND SIDE DATA. C C R INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF C THE ROWS OF A. C C C INTEGER ARRAY OF N ENTRIES SPECIFYING A SUGGESTED C ORDER OF THE COLUMNS. C IS ALSO AN OUTPUT ARGUMENT. C C MAX INTEGER SPECIFYING THE MAXIMUM NUMBER OF OFF-DIAGONAL C NONZERO ENTRIES OF L AND U WHICH MAY BE STORED. C C C OUTPUT ARGUMENTS WHEN M0=0 --- C C C INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF C THE COLUMNS THAT WAS SELECTED BY THE ROUTINE. C C X REAL ARRAY OF N ENTRIES CONTAINING THE SOLUTION. C B AND X MAY SHARE THE SAME STORAGE AREA. C C IERR INTEGER SPECIFYING THE STATUS OF THE RESULTS. IF THE C SOLUTION OF AX = B IS OBTAINED THEN IERR = MAX(1,M) C WHERE M IS THE TOTAL NUMBER OF OFF-DIAGONAL NONZERO C ENTRIES OF L AND U. OTHERWISE IERR.LE.0. C C C GENERAL STORAGE AREAS --- C C IWK INTEGER ARRAY OF DIMENSION 4*N + MAX + 2. C C WK REAL ARRAY OF DIMENSION 2*N + MAX. C C C AFTER AN INITIAL CALL TO RSLV, THE ROUTINE MAY BE RECALLED WITH C M0.NE.0 FOR A NEW B. WHEN M0.NE.0 IT IS ASSUMED THAT N,A,IA,JA, C R,C,IWK,WK HAVE NOT BEEN MODIFIED. THE ROUTINE RETRIEVES THE LU C DECOMPOSITION WHICH WAS OBTAINED ON THE INITIAL CALL TO RSLV C AND SOLVES THE NEW EQUATIONS AX = B. IN THIS CASE A,IA,JA,MAX, C AND IERR ARE NOT REFERENCED. C----------------------------------------------------------------------- REAL A(*), B(N), X(N), WK(*) INTEGER IA(*), JA(*), IWK(*) INTEGER R(N), C(N), Y, T, P C C SET INDICES TO DIVIDE TEMPORARY STORAGE C Y = N + 1 T = Y + N P = N + 1 IT = P + N + 1 IU = IT + N + 1 JT = IU + N IF (M0 .NE. 0) GO TO 20 C C COMPUTE THE INVERSE PERMUTATION OF C C IERR = 0 IF (N .LE. 0) RETURN DO 10 K = 1,N L = C(K) IWK(L) = K 10 CONTINUE C C OBTAIN THE LU DECOMPOSITION OF A C CALL SPLU (A,IA,JA,R,C,IWK(1),N,MAX,WK(1),WK(T),IWK(IT),IWK(JT), * IWK(IU),WK(Y),IWK(P),IERR) IF (IERR .LT. 0) RETURN IERR = MAX0(1,IERR) C C SOLVE THE SYSTEM OF EQUATIONS C 20 CALL RSLV1 (N,R,C,IWK(1),WK(1),WK(T),IWK(IT),IWK(JT),IWK(IU), * B,X,WK(Y)) RETURN END SUBROUTINE RSLV1 (N,R,C,IC,D,T,IT,JT,IU,B,X,Y) INTEGER R(N), C(N), IC(N) INTEGER IT(*), JT(*), IU(N) REAL B(N), D(N), T(*), X(N), Y(N), SUM C C SOLVE LY = B BY FORWARD SUBSTITUTION C DO 11 K = 1,N LK = R(K) SUM = B(LK) JMIN = IT(K) JMAX = IU(K) - 1 IF (JMIN .GT. JMAX) GO TO 11 DO 10 JJ = JMIN,JMAX LJ = JT(JJ) J = IC(LJ) SUM = SUM - T(JJ)*Y(J) 10 CONTINUE 11 Y(K) = SUM/D(K) C C SOLVE UX = B BY BACKWARD SUBSTITUTION C AND REORDER X TO CORRESPOND WITH A C K = N DO 22 I = 1,N SUM = Y(K) JMIN = IU(K) JMAX = IT(K+1) - 1 IF (JMIN .GT. JMAX) GO TO 21 DO 20 JJ = JMIN,JMAX LJ = JT(JJ) J = IC(LJ) SUM = SUM - T(JJ)*Y(J) 20 CONTINUE 21 Y(K) = SUM LK = C(K) X(LK) = Y(K) K = K - 1 22 CONTINUE RETURN END SUBROUTINE TSLV (M0,N,A,IA,JA,B,R,C,MAX,X,IWK,WK,IERR) C----------------------------------------------------------------------- C SOLUTION OF REAL SPARSE EQUATIONS C----------------------------------------------------------------------- C TSLV EMPLOYS GAUSSIAN ELIMINATION WITH COLUMN INTERCHANGES TO C SOLVE THE NXN LINEAR SYSTEM XA = B. THE ARGUMENT M0 SPECIFIES C IF TSLV IS BEING CALLED FOR THE FIRST TIME, OR IF IT IS BEING C RECALLED WHERE A IS THE SAME MATRIX BUT B HAS BEEN MODIFIED. C ON AN INITIAL CALL TO THE ROUTINE (WHEN M0=0) THE LU DECOMPO- C SITION OF A IS OBTAINED WHERE U IS A UNIT UPPER TRIANGULAR C MATRIX. THEN THE EQUATIONS ARE SOLVED. ON SUBSEQUENT CALLS C (WHEN M0.NE.0) THE EQUATIONS ARE SOLVED USING THE DECOMPOSITION C OBTAINED ON THE INITIAL CALL TO TSLV. C C C INPUT ARGUMENTS WHEN M0=0 --- C C N NUMBER OF EQUATIONS AND UNKNOWNS. C C A,IA,JA THE MATRIX A STORED IN SPARSE FORM. C C B ARRAY OF N ENTRIES CONTAINING THE RIGHT HAND SIDE DATA. C C R INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF C THE ROWS OF A. C C C INTEGER ARRAY OF N ENTRIES SPECIFYING A SUGGESTED C ORDER OF THE COLUMNS. C IS ALSO AN OUTPUT ARGUMENT. C C MAX INTEGER SPECIFYING THE MAXIMUM NUMBER OF OFF-DIAGONAL C NONZERO ENTRIES OF L AND U WHICH MAY BE STORED. C C C OUTPUT ARGUMENTS WHEN M0=0 --- C C C INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF C THE COLUMNS THAT WAS SELECTED BY THE ROUTINE. C C X REAL ARRAY OF N ENTRIES CONTAINING THE SOLUTION. C B AND X MAY SHARE THE SAME STORAGE AREA. C C IERR INTEGER SPECIFYING THE STATUS OF THE RESULTS. IF THE C SOLUTION OF AX = B IS OBTAINED THEN IERR = MAX(1,M) C WHERE M IS THE TOTAL NUMBER OF OFF-DIAGONAL NONZERO C ENTRIES OF L AND U. OTHERWISE IERR.LE.0. C C C GENERAL STORAGE AREAS --- C C IWK INTEGER ARRAY OF DIMENSION 4*N + MAX + 2. C C WK REAL ARRAY OF DIMENSION 2*N + MAX. C C C AFTER AN INITIAL CALL TO TSLV, THE ROUTINE MAY BE RECALLED WITH C M0.NE.0 FOR A NEW B. WHEN M0.NE.0 IT IS ASSUMED THAT N,A,IA,JA, C R,C,IWK,WK HAVE NOT BEEN MODIFIED. THE ROUTINE RETRIEVES THE LU C DECOMPOSITION WHICH WAS OBTAINED ON THE INITIAL CALL TO TSLV C AND SOLVES THE NEW EQUATIONS XA = B. IN THIS CASE A,IA,JA,MAX, C AND IERR ARE NOT REFERENCED. C----------------------------------------------------------------------- REAL A(*), B(N), X(N), WK(*) INTEGER IA(*), JA(*), IWK(*) INTEGER R(N), C(N), Y, T, P C C SET INDICES TO DIVIDE TEMPORARY STORAGE C Y = N + 1 T = Y + N P = N + 1 IT = P + N + 1 IU = IT + N + 1 JT = IU + N IF (M0 .NE. 0) GO TO 20 C C COMPUTE THE INVERSE PERMUTATION OF C C IERR = 0 IF (N .LE. 0) RETURN DO 10 K = 1,N L = C(K) IWK(L) = K 10 CONTINUE C C OBTAIN THE LU DECOMPOSITION OF A C CALL SPLU (A,IA,JA,R,C,IWK(1),N,MAX,WK(1),WK(T),IWK(IT),IWK(JT), * IWK(IU),WK(Y),IWK(P),IERR) IF (IERR .LT. 0) RETURN IERR = MAX0(1,IERR) C C SOLVE THE SYSTEM OF EQUATIONS C 20 CALL TSLV1 (N,R,C,IWK(1),WK(1),WK(T),IWK(IT),IWK(JT),IWK(IU), * B,X,WK(Y)) RETURN END SUBROUTINE TSLV1 (N,R,C,IC,D,T,IT,JT,IU,B,X,Y) INTEGER R(N), C(N), IC(N) INTEGER IT(*), JT(*), IU(N) REAL B(N), D(N), T(*), X(N), Y(N) C C SOLVE YU = B BY FORWARD SUBSTITUTION C DO 10 K = 1,N LK = C(K) Y(K) = B(LK) 10 CONTINUE C DO 21 K = 1,N IF (Y(K) .EQ. 0.0) GO TO 21 JMIN = IU(K) JMAX = IT(K+1) - 1 IF (JMIN .GT. JMAX) GO TO 21 DO 20 JJ = JMIN,JMAX LJ = JT(JJ) J = IC(LJ) Y(J) = Y(J) - T(JJ)*Y(K) 20 CONTINUE 21 CONTINUE C C SOLVE XL = Y BY BACKWARD SUBSTITUTION C X(N) = Y(N)/D(N) IF (N .EQ. 1) RETURN C K = N Y(N) = X(N) DO 32 I = 2,N JMIN = IT(K) JMAX = IU(K) - 1 IF (JMIN .GT. JMAX) GO TO 31 DO 30 JJ = JMIN,JMAX LJ = JT(JJ) J = IC(LJ) Y(J) = Y(J) - T(JJ)*Y(K) 30 CONTINUE 31 K = K - 1 Y(K) = Y(K)/D(K) 32 CONTINUE C DO 40 K = 1,N LK = R(K) X(LK) = Y(K) 40 CONTINUE RETURN END SUBROUTINE SPLU (A,IA,JA,R,C,IC,N,MAX,D,T,IT,JT,IU,W,P,IERR) C----------------------------------------------------------------------- C SPLU EMPLOYS GAUSSIAN ELIMINATION WITH COLUMN INTERCHANGES C TO PERFORM THE LU DECOMPOSITION OF A REAL SPARSE MATRIX. C U IS A UNIT UPPER TRIANGULAR MATRIX. C C C INPUT ARGUMENTS --- C C A,IA,JA THE SPARSE MATRIX TO BE DECOMPOSED. C C R INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF C THE ROWS OF A. C C C INTEGER ARRAY OF N ENTRIES SPECIFYING A SUGGESTED C ORDER OF THE COLUMNS. C IS ALSO AN OUTPUT ARGUMENT. C C IC INTEGER ARRAY OF N ENTRIES WHICH IS THE INVERSE OF C C (I.E., IC(C(I)) = I). IC IS ALSO AN OUTPUT ARGUMENT. C C N ORDER OF THE MATRIX A. C C MAX INTEGER SPECIFYING THE MAXIMUM NUMBER OF OFF-DIAGONAL C NONZERO ENTRIES OF L AND U WHICH MAY BE STORED. C C C OUTPUT ARGUMENTS --- C C C INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF C THE COLUMNS THAT WAS SELECTED BY THE ROUTINE. C C IC INTEGER ARRAY OF N ENTRIES WHICH IS THE INVERSE OF C. C C D REAL ARRAY CONTAINING THE N DIAGONAL ELEMENTS OF L. C C T,IT,IU T CONTAINS THE OFF-DIAGONAL NONZERO ELEMENTS OF L AND C U. FOR I = 1,...,N THE OFF-DIAGONAL NONZERO ELEMENTS C OF THE I-TH ROW OF L ARE STORED IN LOCATIONS C IT(I),...,IU(I)-1 OF T, AND THE OFF-DIAGONAL NONZERO C ELEMENTS OF THE I-TH ROW OF U ARE STORED IN LOCATIONS C IU(I),...,IT(I+1)-1 OF T. C C JT INTEGER ARRAY CONTAINING THE COLUMN INDICES (ACCORDING C TO THE ORGINAL COLUMN ORDERING) OF THE ELEMENTS OF T C (I.E., FOR EACH L(I,J) AND U(I,J) IN T, C(J) IS THE C CORRESPONDING COLUMN INDEX IN JT). C C IERR INTEGER SPECIFYING THE STATUS OF THE RESULTS. IF THE C LU DECOMPOSITION IS OBTAINED THEN IERR = THE NUMBER C OF OFF-DIAGONAL ENTRIES OF L AND U WHICH WERE STORED C IN T. OTHERWISE IERR IS ASSIGNED A NEGATIVE VALUE. C C C WORK SPACES --- C C W REAL ARRAY OF DIMENSION N. C C P INTEGER ARRAY OF DIMENSION N+1. C----------------------------------------------------------------------- REAL A(*), D(N), T(MAX), W(N) INTEGER IA(*), JA(*) INTEGER R(N), C(N), IC(N) INTEGER IT(*), JT(MAX), IU(N) INTEGER P(*), PM REAL CONST, WI, WMAX C JPTR = 0 IT(1) = 1 DO 10 J = 1,N W(J) = 0.0 10 CONTINUE C C PERFORM THE LU FACTORIZATION OF THE R(K)-TH ROW OF A C DO 100 K = 1,N LK = R(K) JMIN = IA(LK) JMAX = IA(LK+1) - 1 IF (JMIN .GT. JMAX) GO TO 200 C C SET P TO THE REORDERED ROW OF A C P(N+1) = N + 1 JJ = JMAX 20 LJ = JA(JJ) J = IC(LJ) W(J) = A(JJ) PM = N + 1 21 M = PM PM = P(M) IF (PM - J) 21,210,22 22 P(M) = J P(J) = PM JJ = JJ - 1 IF (JJ .GE. JMIN) GO TO 20 C C PROCESS THE ENTRIES IN THE LOWER TRIANGLE OF A C I = N + 1 30 I = P(I) IF (I .GE. K) GO TO 50 IF (W(I) .EQ. 0.0) GO TO 30 C C L(K,I) IS NONZERO. THEREFORE STORE IT IN L. C JPTR = JPTR + 1 IF (JPTR .GT. MAX) GO TO 230 CONST = W(I) T(JPTR) = CONST JT(JPTR) = C(I) W(I) = 0.0 C C PERFORM ELIMINATION USING THE I-TH ROW OF U C JMIN = IU(I) JMAX = IT(I+1) - 1 IF (JMIN .GT. JMAX) GO TO 30 PM = I DO 43 JJ = JMIN,JMAX LJ = JT(JJ) J = IC(LJ) IF (W(J) .NE. 0.0) GO TO 43 IF (J - PM) 40,43,41 40 PM = I 41 M = PM PM = P(M) IF (PM - J) 41,43,42 42 P(M) = J P(J) = PM PM = J 43 W(J) = W(J) - CONST*T(JJ) GO TO 30 C C SEARCH FOR THE K-TH PIVOT ELEMENT C 50 IF (I .GT. N) GO TO 220 WMAX = ABS(W(I)) MAXI = I PM = I 51 M = PM PM = P(M) IF (PM .GT. N) GO TO 60 WI = ABS(W(PM)) IF (WI .LE. WMAX) GO TO 51 WMAX = WI MAXI = PM MAXIL = M GO TO 51 C C STORE THE PIVOT IN D C 60 IF (WMAX .EQ. 0.0) GO TO 220 D(K) = W(MAXI) C C PERFORM THE COLUMN INTERCHANGE C IF (I .EQ. K) GO TO 70 IF (I .EQ. MAXI) GO TO 70 P(MAXIL) = P(MAXI) GO TO 80 70 I = P(I) C 80 W(MAXI) = W(K) W(K) = 0.0 LK = C(K) LL = C(MAXI) C(K) = LL C(MAXI) = LK IC(LK) = MAXI IC(LL) = K C C THE REMAINING ELEMENTS OF P FORM THE K-TH ROW OF U C IU(K) = JPTR + 1 90 IF (I .GT. N) GO TO 100 IF (W(I) .EQ. 0.0) GO TO 91 JPTR = JPTR + 1 IF (JPTR .GT. MAX) GO TO 230 T(JPTR) = W(I)/D(K) JT(JPTR) = C(I) W(I) = 0.0 91 I = P(I) GO TO 90 C C PREPARE FOR THE NEXT ROW C 100 IT(K+1) = JPTR + 1 C IERR = JPTR RETURN C C -------------------- ERROR RETURN -------------------- C C ROW R(K) IS NULL C 200 IERR = -K RETURN C C ROW R(K) HAS A DUPLICATE ENTRY C 210 IERR = -(N + K) RETURN C C ZERO PIVOT IN ROW R(K) C 220 IERR = -(2*N + K) RETURN C C STORAGE FOR L AND U EXCEEDED ON ROW R(K) C 230 IERR = -(3*N + K) RETURN END SUBROUTINE DSPSLV (N,A,IA,JA,B,R,C,MAX,X,ITEMP,RTEMP,IERR) C----------------------------------------------------------------------- C SOLUTION OF DOUBLE PRECISION SPARSE EQUATIONS C----------------------------------------------------------------------- C DSPSLV CALLS DNSPIV WHICH USES SPARSE GAUSSIAN ELIMINATION WITH C COLUMN INTERCHANGES TO SOLVE THE LINEAR SYSTEM A X = B. THE C ELIMINATION PHASE PERFORMS ROW OPERATIONS ON A AND B TO OBTAIN C A UNIT UPPER TRIANGULAR MATRIX U AND A VECTOR Y. THE SOLUTION C PHASE SOLVES U X = Y. C C INPUT ARGUMENTS--- C C N INTEGER NUMBER OF EQUATIONS AND UNKNOWNS C C A DOUBLE PRECISION ARRAY WITH ONE ENTRY PER NONZERO IN A, C CONTAINING THE ACTUAL NONZEROS. (SEE THE MATRIX STORAGE C DESCRIPTION BELOW) C C IA INTEGER ARRAY OF N+1 ENTRIES CONTAINING ROW POINTERS TO A C (SEE MATRIX STORAGE DESCRIPTION BELOW) C C JA INTEGER ARRAY WITH ONE ENTRY PER NONZERO IN A, CONTAINING C COLUMN NUMBERS OF THE NONZEROS OF A. (SEE MATRIX STORAGE C DESCRIPTION BELOW) C C B DOUBLE PRECISION ARRAY OF N ENTRIES CONTAINING THE RIGHT C HAND SIDE DATA C C R INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF THE C ROWS OF A (I.E., THE ELIMINATION ORDER FOR THE EQUATIONS) C C C INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF THE C COLUMNS OF A. C IS ALSO AN OUTPUT ARGUMENT C C MAX INTEGER NUMBER SPECIFYING MAXIMUM NUMBER OF OFF-DIAGONAL C NONZERO ENTRIES OF U WHICH MAY BE STORED C C ITEMP INTEGER ARRAY OF 3*N + MAX + 2 ENTRIES, FOR INTERNAL USE C C RTEMP DOUBLE PRECISION ARRAY OF N + MAX ENTRIES FOR INTERNAL USE C C C OUTPUT ARGUMENTS--- C C C INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF THE C COLUMNS OF U. C IS ALSO AN INPUT ARGUMENT C C X DOUBLE PRECISION ARRAY OF N ENTRIES CONTAINING THE C SOLUTION VECTOR C C IERR INTEGER NUMBER WHICH INDICATES ERROR CONDITIONS OR C THE ACTUAL NUMBER OF OFF-DIAGONAL ENTRIES IN U (FOR C SUCCESSFUL COMPLETION) C C IERR VALUES ARE--- C C 0 LT IERR SUCCESSFUL COMPLETION. IERR=MAX(1,M) C WHERE M IS THE NUMBER OF OFF-DIAGONAL C NONZERO ENTRIES OF U. C C IERR = 0 ERROR. N IS LESS THAN OR EQUAL TO 0 C C -N LE IERR LT 0 ERROR. ROW NUMBER IABS(IERR) OF A IS C IS NULL C C -2*N LE IERR LT -N ERROR. ROW NUMBER IABS(IERR+N) HAS A C DUPLICATE ENTRY C C -3*N LE IERR LT -2*N ERROR. ROW NUMBER IABS(IERR+2*N) C HAS A ZERO PIVOT C C -4*N LE IERR LT -3*N ERROR. ROW NUMBER IABS(IERR+3*N) C EXCEEDS STORAGE C C C STORAGE OF SPARSE MATRICES--- C C THE SPARSE MATRIX A IS STORED USING THREE ARRAYS IA, JA, AND A. C THE ARRAY A CONTAINS THE NONZEROS OF THE MATRIX ROW-BY-ROW, NOT C NECESSARILY IN ORDER OF INCREASING COLUMN NUMBER. THE ARRAY JA C CONTAINS THE COLUMN NUMBERS CORRESPONDING TO THE NONZEROS STORED C IN THE ARRAY A (I.E., IF THE NONZERO STORED IN A(K) IS IN C COLUMN J, THEN JA(K) = J). THE ARRAY IA CONTAINS POINTERS TO THE C ROWS OF NONZEROS/COLUMN INDICES IN THE ARRAY A/JA (I.E., C A(IA(I))/JA(IA(I)) IS THE FIRST ENTRY FOR ROW I IN THE ARRAY A/JA). C IA(N+1) IS SET SO THAT IA(N+1) - IA(1) = THE NUMBER OF NONZERO C ELEMENTS IN A. C------------------------ DOUBLE PRECISION A(*), B(N), X(N), RTEMP(*) INTEGER IA(*), JA(*), R(N), C(N), ITEMP(*) INTEGER IU, JU, U, Y, P C IERR = 0 IF (N .LE. 0) RETURN C C SET INDICES TO DIVIDE TEMPORARY STORAGE FOR DNSPIV C Y = 1 U = Y + N P = N + 1 IU = P + N + 1 JU = IU + N + 1 C C COMPUTE THE INVERSE PERMUTATION OF C C DO 10 K = 1,N L = C(K) ITEMP(L) = K 10 CONTINUE C C CALL DNSPIV TO PERFORM COMPUTATIONS C CALL DNSPIV (N,IA,JA,A,B,MAX,R,C,ITEMP(1),X,RTEMP(Y),ITEMP(P), * ITEMP(IU),ITEMP(JU),RTEMP(U),IERR) IF (IERR .EQ. 0) IERR = 1 RETURN END SUBROUTINE DNSPIV (N,IA,JA,A,B,MAX,R,C,IC,X,Y,P,IU,JU,U,IERR) C C C DNSPIV USES SPARSE GAUSSIAN ELIMINATION WITH C COLUMN INTERCHANGES TO SOLVE THE LINEAR SYSTEM A X = B. THE C ELIMINATION PHASE PERFORMS ROW OPERATIONS ON A AND B TO OBTAIN C A UNIT UPPER TRIANGULAR MATRIX U AND A VECTOR Y. THE SOLUTION C PHASE SOLVES U X = Y. C C C SEE DSPSLV FOR DESCRIPTIONS OF ALL INPUT AND OUTPUT ARGUMENTS C OTHER THAN THOSE DESCRIBED BELOW C C IC INTEGER ARRAY OF N ENTRIES WHICH IS THE INVERSE OF C C (I.E., IC(C(I)) = I). IC IS BOTH AN INPUT AND OUTPUT C ARGUMENT. C C INPUT ARGUMENTS (USED INTERNALLY ONLY)--- C C Y DOUBLE PRECISION ARRAY OF N ENTRIES USED TO COMPUTE C THE UPDATED RIGHT HAND SIDE C C P INTEGER ARRAY OF N+1 ENTRIES USED FOR A LINKED LIST. C P(N+1) IS THE LIST HEADER, AND THE ENTRY FOLLOWING C P(K) IS IN P(P(K)). THUS, P(N+1) IS THE FIRST DATA C ITEM, P(P(N+1)) IS THE SECOND, ETC. A POINTER OF C N+1 MARKS THE END OF THE LIST C C IU INTEGER ARRAY OF N+1 ENTRIES USED FOR ROW POINTERS TO U C (SEE MATRIX STORAGE DESCRIPTION BELOW) C C JU INTEGER ARRAY OF MAX ENTRIES USED FOR COLUMN NUMBERS OF C THE NONZEROS IN THE STRICT UPPER TRIANGLE OF U. (SEE C MATRIX STORAGE DESCRIPTION BELOW) C C U DOUBLE PRECISION ARRAY OF MAX ENTRIES USED FOR THE ACTUAL C NONZEROS IN THE STRICT UPPER TRIANGLE OF U. (SEE MATRIX C STORAGE DESCRIPTION BELOW) C C C STORAGE OF SPARSE MATRICES--- C C THE SPARSE MATRIX A IS STORED USING THREE ARRAYS IA, JA, AND A. C THE ARRAY A CONTAINS THE NONZEROS OF THE MATRIX ROW-BY-ROW, NOT C NECESSARILY IN ORDER OF INCREASING COLUMN NUMBER. THE ARRAY JA C CONTAINS THE COLUMN NUMBERS CORRESPONDING TO THE NONZEROS STORED C IN THE ARRAY A (I.E., IF THE NONZERO STORED IN A(K) IS IN C COLUMN J, THEN JA(K) = J). THE ARRAY IA CONTAINS POINTERS TO THE C ROWS OF NONZEROS/COLUMN INDICES IN THE ARRAY A/JA (I.E., C A(IA(I))/JA(IA(I)) IS THE FIRST ENTRY FOR ROW I IN THE ARRAY A/JA). C IA(N+1) IS SET SO THAT IA(N+1) - IA(1) = THE NUMBER OF NONZEROS IN C A. IU, JU, AND U ARE USED IN A SIMILAR WAY TO STORE THE STRICT UPPER C TRIANGLE OF U, EXCEPT THAT JU ACTUALLY CONTAINS C(J) INSTEAD OF J C C DOUBLE PRECISION A(*), B(N), U(MAX), X(N), Y(N) DOUBLE PRECISION DK, LKI, XPV, XPVMAX, YK INTEGER C(N), IA(*), IC(N), IU(*), JA(*), JU(MAX), P(*), R(N) INTEGER CK, PK, PPK, PV, V, VI, VJ, VK C C INITIALIZE WORK STORAGE AND POINTERS TO JU C DO 10 J = 1,N X(J) = 0.D0 10 CONTINUE IU(1) = 1 JUPTR = 0 C C PERFORM SYMBOLIC AND NUMERIC FACTORIZATION ROW BY ROW C VK (VI,VJ) IS THE GRAPH VERTEX FOR ROW K (I,J) OF U C DO 170 K = 1,N C C INITIALIZE LINKED LIST AND FREE STORAGE FOR THIS ROW C THE R(K)-TH ROW OF A BECOMES THE K-TH ROW OF U. C P(N+1) = N+1 VK = R(K) C C SET UP ADJACENCY LIST FOR VK, ORDERED IN C CURRENT COLUMN ORDER OF U. THE LOOP INDEX C GOES DOWNWARD TO EXPLOIT ANY COLUMNS C FROM A IN CORRECT RELATIVE ORDER C JMIN = IA(VK) JMAX = IA(VK+1) - 1 IF (JMIN .GT. JMAX) GO TO 1002 J = JMAX 20 JAJ = JA(J) VJ = IC(JAJ) C C STORE A(K,J) IN WORK VECTOR C X(VJ) = A(J) C THIS CODE INSERTS VJ INTO ADJACENCY LIST OF VK PPK = N+1 30 PK = PPK PPK = P(PK) IF (PPK - VJ) 30,1003,40 40 P(VJ) = PPK P(PK) = VJ J = J - 1 IF (J .GE. JMIN) GO TO 20 C C THE FOLLOWING CODE COMPUTES THE K-TH ROW OF U C VI = N+1 YK = B(VK) 50 VI = P(VI) IF (VI .GE. K) GO TO 110 C C VI LT VK -- PROCESS THE L(K,I) ELEMENT AND MERGE THE C ADJACENCY OF VI WITH THE ORDERED ADJACENCY OF VK C LKI = - X(VI) X(VI) = 0.D0 C C ADJUST RIGHT HAND SIDE TO REFLECT ELIMINATION C YK = YK + LKI * Y(VI) PPK = VI JMIN = IU(VI) JMAX = IU(VI+1) - 1 IF (JMIN .GT. JMAX) GO TO 50 DO 100 J = JMIN,JMAX JUJ = JU(J) VJ = IC(JUJ) C C IF VJ IS ALREADY IN THE ADJACENCY OF VK, C SKIP THE INSERTION C IF (X(VJ) .NE. 0.D0) GO TO 90 C C INSERT VJ IN ADJACENCY LIST OF VK. C RESET PPK TO VI IF WE HAVE PASSED THE CORRECT C INSERTION SPOT. (THIS HAPPENS WHEN THE ADJACENCY OF C VI IS NOT IN CURRENT COLUMN ORDER DUE TO PIVOTING.) C IF (VJ - PPK) 60,90,70 60 PPK = VI 70 PK = PPK PPK = P(PK) IF (PPK - VJ) 70,90,80 80 P(VJ) = PPK P(PK) = VJ PPK = VJ C C COMPUTE L(K,J) = L(K,J) - L(K,I)*U(I,J) FOR L(K,I) NONZERO C COMPUTE U*(K,J) = U*(K,J) - L(K,I)*U(I,J) FOR U(K,J) NONZERO C (U*(K,J) = U(K,J)*D(K,K)) C 90 X(VJ) = X(VJ) + LKI * U(J) 100 CONTINUE GO TO 50 C C PIVOT--INTERCHANGE LARGEST ENTRY OF K-TH ROW OF U WITH C THE DIAGONAL ENTRY. C C FIND LARGEST ENTRY, COUNTING OFF-DIAGONAL NONZEROS C 110 IF (VI .GT. N) GO TO 1004 XPVMAX = DABS(X(VI)) MAXC = VI NZCNT = 0 PV = VI 120 V = PV PV = P(PV) IF (PV .GT. N) GO TO 130 NZCNT = NZCNT + 1 XPV = DABS(X(PV)) IF (XPV .LE. XPVMAX) GO TO 120 XPVMAX = XPV MAXC = PV MAXCL = V GO TO 120 130 IF (XPVMAX .EQ. 0.D0) GO TO 1004 C C IF VI = K, THEN THERE IS AN ENTRY FOR DIAGONAL C WHICH MUST BE DELETED. OTHERWISE, DELETE THE C ENTRY WHICH WILL BECOME THE DIAGONAL ENTRY C IF (VI .EQ. K) GO TO 140 IF (VI .EQ. MAXC) GO TO 140 P(MAXCL) = P(MAXC) GO TO 150 140 VI = P(VI) C C COMPUTE D(K) = 1/L(K,K) AND PERFORM INTERCHANGE. C 150 DK = 1.D0 / X(MAXC) X(MAXC) = X(K) I = C(K) C(K) = C(MAXC) C(MAXC) = I CK = C(K) IC(CK) = K IC(I) = MAXC X(K) = 0.D0 C C UPDATE RIGHT HAND SIDE. C Y(K) = YK * DK C C COMPUTE VALUE FOR IU(K+1) AND CHECK FOR STORAGE OVERFLOW C IU(K+1) = IU(K) + NZCNT IF (IU(K+1) .GT. MAX+1) GO TO 1005 C C MOVE COLUMN INDICES FROM LINKED LIST TO JU. C COLUMNS ARE STORED IN CURRENT ORDER WITH ORIGINAL C COLUMN NUMBER (C(J)) STORED FOR CURRENT COLUMN J C IF (VI .GT. N) GO TO 170 J = VI 160 JUPTR = JUPTR + 1 JU(JUPTR) = C(J) U(JUPTR) = X(J) * DK X(J) = 0.D0 J = P(J) IF (J .LE. N) GO TO 160 170 CONTINUE C C BACKSOLVE U X = Y, AND REORDER X TO CORRESPOND WITH A C K = N DO 200 I = 1,N YK = Y(K) JMIN = IU(K) JMAX = IU(K+1) - 1 IF (JMIN .GT. JMAX) GO TO 190 DO 180 J = JMIN,JMAX JUJ = JU(J) JUJ = IC(JUJ) YK = YK - U(J) * Y(JUJ) 180 CONTINUE 190 Y(K) = YK CK = C(K) X(CK) = YK K = K - 1 200 CONTINUE C C RETURN WITH IERR = NUMBER OF OFF-DIAGONAL NONZEROS IN U C IERR = IU(N+1) - IU(1) RETURN C C ERROR RETURNS C C ROW K OF A IS NULL C 1002 IERR = -K RETURN C C ROW K OF A HAS A DUPLICATE ENTRY C 1003 IERR = -(N+K) RETURN C C ZERO PIVOT IN ROW K C 1004 IERR = -(2*N+K) RETURN C C STORAGE FOR U EXCEEDED ON ROW K C 1005 IERR = -(3*N+K) RETURN END SUBROUTINE DSLV (M0,N,A,IA,JA,B,R,C,MAX,X,IWK,WK,IERR) C----------------------------------------------------------------------- C SOLUTION OF DOUBLE PRECISION SPARSE EQUATIONS C----------------------------------------------------------------------- C DSLV EMPLOYS GAUSSIAN ELIMINATION WITH COLUMN INTERCHANGES TO C SOLVE THE NXN LINEAR SYSTEM AX = B. THE ARGUMENT M0 SPECIFIES C IF DSLV IS BEING CALLED FOR THE FIRST TIME, OR IF IT IS BEING C RECALLED WHERE A IS THE SAME MATRIX BUT B HAS BEEN MODIFIED. C ON AN INITIAL CALL TO THE ROUTINE (WHEN M0=0) THE LU DECOMPO- C SITION OF A IS OBTAINED WHERE U IS A UNIT UPPER TRIANGULAR C MATRIX. THEN THE EQUATIONS ARE SOLVED. ON SUBSEQUENT CALLS C (WHEN M0.NE.0) THE EQUATIONS ARE SOLVED USING THE DECOMPOSITION C OBTAINED ON THE INITIAL CALL TO DSLV. C C C INPUT ARGUMENTS WHEN M0=0 --- C C N NUMBER OF EQUATIONS AND UNKNOWNS. C C A,IA,JA THE DOUBLE PRECISION MATRIX A STORED IN SPARSE FORM. C C B DOUBLE PRECISION ARRAY OF N ENTRIES CONTAINING THE C RIGHT HAND SIDE DATA. C C R INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF C THE ROWS OF A. C C C INTEGER ARRAY OF N ENTRIES SPECIFYING A SUGGESTED C ORDER OF THE COLUMNS. C IS ALSO AN OUTPUT ARGUMENT. C C MAX INTEGER SPECIFYING THE MAXIMUM NUMBER OF OFF-DIAGONAL C NONZERO ENTRIES OF L AND U WHICH MAY BE STORED. C C C OUTPUT ARGUMENTS WHEN M0=0 --- C C C INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF C THE COLUMNS THAT WAS SELECTED BY THE ROUTINE. C C X DOUBLE PRECISION ARRAY OF N ENTRIES CONTAINING THE C SOLUTION. B AND X MAY SHARE THE SAME STORAGE AREA. C C IERR INTEGER SPECIFYING THE STATUS OF THE RESULTS. IF THE C SOLUTION OF AX = B IS OBTAINED THEN IERR = MAX(1,M) C WHERE M IS THE TOTAL NUMBER OF OFF-DIAGONAL NONZERO C ENTRIES OF L AND U. OTHERWISE IERR.LE.0. C C C GENERAL STORAGE AREAS --- C C IWK INTEGER ARRAY OF DIMENSION 4*N + MAX + 2. C C WK DOUBLE PRECISION ARRAY OF DIMENSION 2*N + MAX. C C C AFTER AN INITIAL CALL TO DSLV, THE ROUTINE MAY BE RECALLED WITH C M0.NE.0 FOR A NEW B. WHEN M0.NE.0 IT IS ASSUMED THAT N,A,IA,JA, C R,C,IWK,WK HAVE NOT BEEN MODIFIED. THE ROUTINE RETRIEVES THE LU C DECOMPOSITION WHICH WAS OBTAINED ON THE INITIAL CALL TO DSLV C AND SOLVES THE NEW EQUATIONS AX = B. IN THIS CASE A,IA,JA,MAX, C AND IERR ARE NOT REFERENCED. C----------------------------------------------------------------------- DOUBLE PRECISION A(*), B(N), X(N), WK(*) INTEGER IA(*), JA(*), IWK(*) INTEGER R(N), C(N), Y, T, P C C SET INDICES TO DIVIDE TEMPORARY STORAGE C Y = N + 1 T = Y + N P = N + 1 IT = P + N + 1 IU = IT + N + 1 JT = IU + N IF (M0 .NE. 0) GO TO 20 C C COMPUTE THE INVERSE PERMUTATION OF C C IERR = 0 IF (N .LE. 0) RETURN DO 10 K = 1,N L = C(K) IWK(L) = K 10 CONTINUE C C OBTAIN THE LU DECOMPOSITION OF A C CALL DSPLU (A,IA,JA,R,C,IWK(1),N,MAX,WK(1),WK(T),IWK(IT),IWK(JT), * IWK(IU),WK(Y),IWK(P),IERR) IF (IERR .LT. 0) RETURN IERR = MAX0(1,IERR) C C SOLVE THE SYSTEM OF EQUATIONS C 20 CALL DSLV1 (N,R,C,IWK(1),WK(1),WK(T),IWK(IT),IWK(JT),IWK(IU), * B,X,WK(Y)) RETURN END SUBROUTINE DSLV1 (N,R,C,IC,D,T,IT,JT,IU,B,X,Y) INTEGER R(N), C(N), IC(N) INTEGER IT(*), JT(*), IU(N) DOUBLE PRECISION B(N), D(N), T(*), X(N), Y(N), SUM C C SOLVE LY = B BY FORWARD SUBSTITUTION C DO 11 K = 1,N LK = R(K) SUM = B(LK) JMIN = IT(K) JMAX = IU(K) - 1 IF (JMIN .GT. JMAX) GO TO 11 DO 10 JJ = JMIN,JMAX LJ = JT(JJ) J = IC(LJ) SUM = SUM - T(JJ)*Y(J) 10 CONTINUE 11 Y(K) = SUM/D(K) C C SOLVE UX = B BY BACKWARD SUBSTITUTION C AND REORDER X TO CORRESPOND WITH A C K = N DO 22 I = 1,N SUM = Y(K) JMIN = IU(K) JMAX = IT(K+1) - 1 IF (JMIN .GT. JMAX) GO TO 21 DO 20 JJ = JMIN,JMAX LJ = JT(JJ) J = IC(LJ) SUM = SUM - T(JJ)*Y(J) 20 CONTINUE 21 Y(K) = SUM LK = C(K) X(LK) = Y(K) K = K - 1 22 CONTINUE RETURN END SUBROUTINE DTSLV (M0,N,A,IA,JA,B,R,C,MAX,X,IWK,WK,IERR) C----------------------------------------------------------------------- C SOLUTION OF DOUBLE PRECISION SPARSE EQUATIONS C----------------------------------------------------------------------- C DTSLV EMPLOYS GAUSSIAN ELIMINATION WITH COLUMN INTERCHANGES TO C SOLVE THE NXN LINEAR SYSTEM XA = B. THE ARGUMENT M0 SPECIFIES C IF DTSLV IS BEING CALLED FOR THE FIRST TIME, OR IF IT IS BEING C RECALLED WHERE A IS THE SAME MATRIX BUT B HAS BEEN MODIFIED. C ON AN INITIAL CALL TO THE ROUTINE (WHEN M0=0) THE LU DECOMPO- C SITION OF A IS OBTAINED WHERE U IS A UNIT UPPER TRIANGULAR C MATRIX. THEN THE EQUATIONS ARE SOLVED. ON SUBSEQUENT CALLS C (WHEN M0.NE.0) THE EQUATIONS ARE SOLVED USING THE DECOMPOSITION C OBTAINED ON THE INITIAL CALL TO DTSLV. C C C INPUT ARGUMENTS WHEN M0=0 --- C C N NUMBER OF EQUATIONS AND UNKNOWNS. C C A,IA,JA THE DOUBLE PRECISION MATRIX A STORED IN SPARSE FORM. C C B DOUBLE PRECISION ARRAY OF N ENTRIES CONTAINING THE C RIGHT HAND SIDE DATA. C C R INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF C THE ROWS OF A. C C C INTEGER ARRAY OF N ENTRIES SPECIFYING A SUGGESTED C ORDER OF THE COLUMNS. C IS ALSO AN OUTPUT ARGUMENT. C C MAX INTEGER SPECIFYING THE MAXIMUM NUMBER OF OFF-DIAGONAL C NONZERO ENTRIES OF L AND U WHICH MAY BE STORED. C C C OUTPUT ARGUMENTS WHEN M0=0 --- C C C INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF C THE COLUMNS THAT WAS SELECTED BY THE ROUTINE. C C X DOUBLE PRECISION ARRAY OF N ENTRIES CONTAINING THE C SOLUTION. B AND X MAY SHARE THE SAME STORAGE AREA. C C IERR INTEGER SPECIFYING THE STATUS OF THE RESULTS. IF THE C SOLUTION OF AX = B IS OBTAINED THEN IERR = MAX(1,M) C WHERE M IS THE TOTAL NUMBER OF OFF-DIAGONAL NONZERO C ENTRIES OF L AND U. OTHERWISE IERR.LE.0. C C C GENERAL STORAGE AREAS --- C C IWK INTEGER ARRAY OF DIMENSION 4*N + MAX + 2. C C WK DOUBLE PRECISION ARRAY OF DIMENSION 2*N + MAX. C C C AFTER AN INITIAL CALL TO DTSLV, THE ROUTINE MAY BE RECALLED WITH C M0.NE.0 FOR A NEW B. WHEN M0.NE.0 IT IS ASSUMED THAT N,A,IA,JA, C R,C,IWK,WK HAVE NOT BEEN MODIFIED. THE ROUTINE RETRIEVES THE LU C DECOMPOSITION WHICH WAS OBTAINED ON THE INITIAL CALL TO DTSLV C AND SOLVES THE NEW EQUATIONS XA = B. IN THIS CASE A,IA,JA,MAX, C AND IERR ARE NOT REFERENCED. C----------------------------------------------------------------------- DOUBLE PRECISION A(*), B(N), X(N), WK(*) INTEGER IA(*), JA(*), IWK(*) INTEGER R(N), C(N), Y, T, P C C SET INDICES TO DIVIDE TEMPORARY STORAGE C Y = N + 1 T = Y + N P = N + 1 IT = P + N + 1 IU = IT + N + 1 JT = IU + N IF (M0 .NE. 0) GO TO 20 C C COMPUTE THE INVERSE PERMUTATION OF C C IERR = 0 IF (N .LE. 0) RETURN DO 10 K = 1,N L = C(K) IWK(L) = K 10 CONTINUE C C OBTAIN THE LU DECOMPOSITION OF A C CALL DSPLU (A,IA,JA,R,C,IWK(1),N,MAX,WK(1),WK(T),IWK(IT),IWK(JT), * IWK(IU),WK(Y),IWK(P),IERR) IF (IERR .LT. 0) RETURN IERR = MAX0(1,IERR) C C SOLVE THE SYSTEM OF EQUATIONS C 20 CALL DTSLV1 (N,R,C,IWK(1),WK(1),WK(T),IWK(IT),IWK(JT),IWK(IU), * B,X,WK(Y)) RETURN END SUBROUTINE DTSLV1 (N,R,C,IC,D,T,IT,JT,IU,B,X,Y) INTEGER R(N), C(N), IC(N) INTEGER IT(*), JT(*), IU(N) DOUBLE PRECISION B(N), D(N), T(*), X(N), Y(N) C C SOLVE YU = B BY FORWARD SUBSTITUTION C DO 10 K = 1,N LK = C(K) Y(K) = B(LK) 10 CONTINUE C DO 21 K = 1,N IF (Y(K) .EQ. 0.D0) GO TO 21 JMIN = IU(K) JMAX = IT(K+1) - 1 IF (JMIN .GT. JMAX) GO TO 21 DO 20 JJ = JMIN,JMAX LJ = JT(JJ) J = IC(LJ) Y(J) = Y(J) - T(JJ)*Y(K) 20 CONTINUE 21 CONTINUE C C SOLVE XL = Y BY BACKWARD SUBSTITUTION C X(N) = Y(N)/D(N) IF (N .EQ. 1) RETURN C K = N Y(N) = X(N) DO 32 I = 2,N JMIN = IT(K) JMAX = IU(K) - 1 IF (JMIN .GT. JMAX) GO TO 31 DO 30 JJ = JMIN,JMAX LJ = JT(JJ) J = IC(LJ) Y(J) = Y(J) - T(JJ)*Y(K) 30 CONTINUE 31 K = K - 1 Y(K) = Y(K)/D(K) 32 CONTINUE C DO 40 K = 1,N LK = R(K) X(LK) = Y(K) 40 CONTINUE RETURN END SUBROUTINE DSPLU (A,IA,JA,R,C,IC,N,MAX,D,T,IT,JT,IU,W,P,IERR) C----------------------------------------------------------------------- C DSPLU EMPLOYS GAUSSIAN ELIMINATION WITH COLUMN INTERCHANGES C TO PERFORM THE LU DECOMPOSITION OF A DOUBLE PRECISION SPARSE C MATRIX. U IS A UNIT UPPER TRIANGULAR MATRIX. C C C INPUT ARGUMENTS --- C C A,IA,JA THE SPARSE MATRIX TO BE DECOMPOSED. C C R INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF C THE ROWS OF A. C C C INTEGER ARRAY OF N ENTRIES SPECIFYING A SUGGESTED C ORDER OF THE COLUMNS. C IS ALSO AN OUTPUT ARGUMENT. C C IC INTEGER ARRAY OF N ENTRIES WHICH IS THE INVERSE OF C C (I.E., IC(C(I)) = I). IC IS ALSO AN OUTPUT ARGUMENT. C C N ORDER OF THE MATRIX A. C C MAX INTEGER SPECIFYING THE MAXIMUM NUMBER OF OFF-DIAGONAL C NONZERO ENTRIES OF L AND U WHICH MAY BE STORED. C C C OUTPUT ARGUMENTS --- C C C INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF C THE COLUMNS THAT WAS SELECTED BY THE ROUTINE. C C IC INTEGER ARRAY OF N ENTRIES WHICH IS THE INVERSE OF C. C C D DOUBLE PRECISION ARRAY CONTAINING THE N DIAGONAL C ELEMENTS OF L. C C T,IT,IU T CONTAINS THE OFF-DIAGONAL NONZERO ELEMENTS OF L AND C U. FOR I = 1,...,N THE OFF-DIAGONAL NONZERO ELEMENTS C OF THE I-TH ROW OF L ARE STORED IN LOCATIONS C IT(I),...,IU(I)-1 OF T, AND THE OFF-DIAGONAL NONZERO C ELEMENTS OF THE I-TH ROW OF U ARE STORED IN LOCATIONS C IU(I),...,IT(I+1)-1 OF T. C C JT INTEGER ARRAY CONTAINING THE COLUMN INDICES (ACCORDING C TO THE ORGINAL COLUMN ORDERING) OF THE ELEMENTS OF T C (I.E., FOR EACH L(I,J) AND U(I,J) IN T, C(J) IS THE C CORRESPONDING COLUMN INDEX IN JT). C C IERR INTEGER SPECIFYING THE STATUS OF THE RESULTS. IF THE C LU DECOMPOSITION IS OBTAINED THEN IERR = THE NUMBER C OF OFF-DIAGONAL ENTRIES OF L AND U WHICH WERE STORED C IN T. OTHERWISE IERR IS ASSIGNED A NEGATIVE VALUE. C C C WORK SPACES --- C C W DOUBLE PRECISION ARRAY OF DIMENSION N. C C P INTEGER ARRAY OF DIMENSION N+1. C----------------------------------------------------------------------- DOUBLE PRECISION A(*), D(N), T(MAX), W(N) INTEGER IA(*), JA(*) INTEGER R(N), C(N), IC(N) INTEGER IT(*), JT(MAX), IU(N) INTEGER P(*), PM DOUBLE PRECISION CONST, WI, WMAX C JPTR = 0 IT(1) = 1 DO 10 J = 1,N W(J) = 0.D0 10 CONTINUE C C PERFORM THE LU FACTORIZATION OF THE R(K)-TH ROW OF A C DO 100 K = 1,N LK = R(K) JMIN = IA(LK) JMAX = IA(LK+1) - 1 IF (JMIN .GT. JMAX) GO TO 200 C C SET P TO THE REORDERED ROW OF A C P(N+1) = N + 1 JJ = JMAX 20 LJ = JA(JJ) J = IC(LJ) W(J) = A(JJ) PM = N + 1 21 M = PM PM = P(M) IF (PM - J) 21,210,22 22 P(M) = J P(J) = PM JJ = JJ - 1 IF (JJ .GE. JMIN) GO TO 20 C C PROCESS THE ENTRIES IN THE LOWER TRIANGLE OF A C I = N + 1 30 I = P(I) IF (I .GE. K) GO TO 50 IF (W(I) .EQ. 0.D0) GO TO 30 C C L(K,I) IS NONZERO. THEREFORE STORE IT IN L. C JPTR = JPTR + 1 IF (JPTR .GT. MAX) GO TO 230 CONST = W(I) T(JPTR) = CONST JT(JPTR) = C(I) W(I) = 0.D0 C C PERFORM ELIMINATION USING THE I-TH ROW OF U C JMIN = IU(I) JMAX = IT(I+1) - 1 IF (JMIN .GT. JMAX) GO TO 30 PM = I DO 43 JJ = JMIN,JMAX LJ = JT(JJ) J = IC(LJ) IF (W(J) .NE. 0.D0) GO TO 43 IF (J - PM) 40,43,41 40 PM = I 41 M = PM PM = P(M) IF (PM - J) 41,43,42 42 P(M) = J P(J) = PM PM = J 43 W(J) = W(J) - CONST*T(JJ) GO TO 30 C C SEARCH FOR THE K-TH PIVOT ELEMENT C 50 IF (I .GT. N) GO TO 220 WMAX = DABS(W(I)) MAXI = I PM = I 51 M = PM PM = P(M) IF (PM .GT. N) GO TO 60 WI = DABS(W(PM)) IF (WI .LE. WMAX) GO TO 51 WMAX = WI MAXI = PM MAXIL = M GO TO 51 C C STORE THE PIVOT IN D C 60 IF (WMAX .EQ. 0.D0) GO TO 220 D(K) = W(MAXI) C C PERFORM THE COLUMN INTERCHANGE C IF (I .EQ. K) GO TO 70 IF (I .EQ. MAXI) GO TO 70 P(MAXIL) = P(MAXI) GO TO 80 70 I = P(I) C 80 W(MAXI) = W(K) W(K) = 0.D0 LK = C(K) LL = C(MAXI) C(K) = LL C(MAXI) = LK IC(LK) = MAXI IC(LL) = K C C THE REMAINING ELEMENTS OF P FORM THE K-TH ROW OF U C IU(K) = JPTR + 1 90 IF (I .GT. N) GO TO 100 IF (W(I) .EQ. 0.D0) GO TO 91 JPTR = JPTR + 1 IF (JPTR .GT. MAX) GO TO 230 T(JPTR) = W(I)/D(K) JT(JPTR) = C(I) W(I) = 0.D0 91 I = P(I) GO TO 90 C C PREPARE FOR THE NEXT ROW C 100 IT(K+1) = JPTR + 1 C IERR = JPTR RETURN C C -------------------- ERROR RETURN -------------------- C C ROW R(K) IS NULL C 200 IERR = -K RETURN C C ROW R(K) HAS A DUPLICATE ENTRY C 210 IERR = -(N + K) RETURN C C ZERO PIVOT IN ROW R(K) C 220 IERR = -(2*N + K) RETURN C C STORAGE FOR L AND U EXCEEDED ON ROW R(K) C 230 IERR = -(3*N + K) RETURN END SUBROUTINE S1CND (N, A, IA, JA, R, C, MAX, COND, IWK, WK, IERR) C----------------------------------------------------------------------- C COMPUTATION OF THE L1 CONDITION NUMBER C OF A SPARSE MATRIX A C----------------------------------------------------------------------- REAL A(*), WK(*) INTEGER IA(*), JA(*), R(N), C(N), IWK(*) C----------------------- C REAL WK(4*N + MAX) C INTEGER IWK(5*N + MAX + 2) C----------------------- COND = 0.0 CALL S1NRM (A, IA, JA, N, N, ANORM, WK) IF (ANORM .EQ. 0.0) GO TO 50 C IX = 2*N + MAX + 1 IV = IX + N ISGN = 4*N + MAX + 3 C KASE = 0 AINORM = 0.0 CALL SONEST (N, WK(IV), WK(IX), IWK(ISGN), AINORM, KASE, * ITER, J, JUMP) CALL RSLV (0, N, A, IA, JA, WK(IX), R, C, MAX, WK(IX), * IWK(1), WK(1), IERR) C C CHECK IF A IS SINGULAR OR IF THERE ARE ERRORS C IF (IERR .GT. 0) GO TO 20 IF (IABS(IERR) .LE. N) GO TO 50 IERR = IERR + N IF (IABS(IERR) .LE. N) RETURN IERR = IERR + N IF (IABS(IERR) .LE. N) GO TO 50 RETURN C C GENERAL LOOP TO ESTIMATE THE NORM AINORM C OF THE INVERSE OF A C 20 CALL SONEST (N, WK(IV), WK(IX), IWK(ISGN), AINORM, KASE, * ITER, J, JUMP) IF (KASE .EQ. 0) GO TO 40 IF (KASE .NE. 1) GO TO 30 CALL RSLV (1, N, A, IA, JA, WK(IX), R, C, MAX, WK(IX), * IWK(1), WK(1), IERR) GO TO 20 30 CALL TSLV (1, N, A, IA, JA, WK(IX), R, C, MAX, WK(IX), * IWK(1), WK(1), IERR) GO TO 20 C C COMPUTE THE VALUE OF COND C 40 COND = ANORM*AINORM RETURN C C SINGULAR CASE C 50 IERR = 0 RETURN END SUBROUTINE DS1CND (N, A, IA, JA, R, C, MAX, COND, IWK, WK, IERR) C----------------------------------------------------------------------- C COMPUTATION OF THE L1 CONDITION NUMBER C OF A SPARSE MATRIX A C----------------------------------------------------------------------- DOUBLE PRECISION A(*), COND, WK(*), ANORM, AINORM INTEGER IA(*), JA(*), R(N), C(N), IWK(*) C----------------------- C DOUBLE PRECISION WK(4*N + MAX) C INTEGER IWK(5*N + MAX + 2) C----------------------- COND = 0.D0 CALL DS1NRM (A, IA, JA, N, N, ANORM, WK) IF (ANORM .EQ. 0.D0) GO TO 50 C IX = 2*N + MAX + 1 IV = IX + N ISGN = 4*N + MAX + 3 C KASE = 0 AINORM = 0.D0 CALL DONEST (N, WK(IV), WK(IX), IWK(ISGN), AINORM, KASE, * ITER, J, JUMP) CALL DSLV (0, N, A, IA, JA, WK(IX), R, C, MAX, WK(IX), * IWK(1), WK(1), IERR) C C CHECK IF A IS SINGULAR OR IF THERE ARE ERRORS C IF (IERR .GT. 0) GO TO 20 IF (IABS(IERR) .LE. N) GO TO 50 IERR = IERR + N IF (IABS(IERR) .LE. N) RETURN IERR = IERR + N IF (IABS(IERR) .LE. N) GO TO 50 RETURN C C GENERAL LOOP TO ESTIMATE THE NORM AINORM C OF THE INVERSE OF A C 20 CALL DONEST (N, WK(IV), WK(IX), IWK(ISGN), AINORM, KASE, * ITER, J, JUMP) IF (KASE .EQ. 0) GO TO 40 IF (KASE .NE. 1) GO TO 30 CALL DSLV (1, N, A, IA, JA, WK(IX), R, C, MAX, WK(IX), * IWK(1), WK(1), IERR) GO TO 20 30 CALL DTSLV (1, N, A, IA, JA, WK(IX), R, C, MAX, WK(IX), * IWK(1), WK(1), IERR) GO TO 20 C C COMPUTE THE VALUE OF COND C 40 COND = ANORM*AINORM RETURN C C SINGULAR CASE C 50 IERR = 0 RETURN END SUBROUTINE SONEST (N, V, X, ISGN, ANORM, KASE, ITER, J, JUMP) REAL V(N), X(N) INTEGER ISGN(N) C----------------------------------------------------------------------- C C SONEST ESTIMATES THE 1-NORM OF A SQUARE, REAL MATRIX A. C REVERSE COMMUNICATION IS USED FOR EVALUATING C MATRIX-VECTOR PRODUCTS. C C ON ENTRY C C N THE ORDER OF THE MATRIX. N .GE. 1. C C KASE INTEGER (= 0). C C ON INTERMEDIATE RETURNS C C KASE = 1 OR 2. C C X MUST BE OVERWRITTEN BY C C A*X, IF KASE = 1, C TRANSPOSE(A)*X, IF KASE = 2, C C AND SONEST MUST BE RE-CALLED, WITH ALL THE OTHER C PARAMETERS UNCHANGED. C C ITER NUMBER OF THE CURRENT ITERATION. C C ON FINAL RETURN C C KASE = 0. C C ANORM CONTAINS AN ESTIMATE (A LOWER BOUND) FOR NORM(A). C C V = A*W, WHERE ANORM = NORM(V)/NORM(W) C (W IS NOT RETURNED). C C ITER NUMBER OF INTERATIONS TAKEN. C C WRITTEN BY NICK HIGHAM, UNIVERSITY OF MANCHESTER. MODIFIED C BY A.H. MORRIS (NSWC). C C REFERENCE C N.J. HIGHAM (1987) FORTRAN CODES FOR ESTIMATING C THE 1-NORM OF A REAL OR COMPLEX MATRIX, WITH APPLICATIONS C TO CONDITION ESTIMATION, NUMERICAL ANALYSIS REPORT NO. 135, C UNIVERSITY OF MANCHESTER, MANCHESTER M13 9PL, ENGLAND. C C----------------------------------------------------------------------- DATA ITMAX /5/ C IF (KASE .NE. 0) GO TO 20 T = 1.0/FLOAT(N) DO 10 I = 1,N X(I) = T 10 CONTINUE ITER = 0 KASE = 1 JUMP = 1 RETURN 20 GO TO (100, 200, 300, 400, 500), JUMP C C ................ ENTRY (JUMP = 1) C FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. C 100 ITER = 1 IF (N .GT. 1) GO TO 110 V(1) = X(1) ANORM = ABS(V(1)) GO TO 510 C 110 ANORM = SASUM(N,X,1) DO 120 I = 1,N ISGN(I) = 1 IF (X(I) .LT. 0.0) ISGN(I) = -1 X(I) = ISGN(I) 120 CONTINUE KASE = 2 JUMP = 2 RETURN C C ................ ENTRY (JUMP = 2) C FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. C 200 ITER = 2 J = ISAMAX(N,X,1) C C MAIN LOOP - ITERATIONS 2,3,...,ITMAX. C 210 DO 220 I = 1,N X(I) = 0.0 220 CONTINUE X(J) = 1.0 KASE = 1 JUMP = 3 RETURN C C ................ ENTRY (JUMP = 3) C X HAS BEEN OVERWRITTEN BY A*X. C 300 CALL SCOPY (N,X,1,V,1) ANRM = ANORM ANORM = SASUM(N,V,1) DO 310 I = 1,N L = 1 IF (X(I) .LT. 0.0) L = -1 IF (L .NE. ISGN(I)) GO TO 320 310 CONTINUE C REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. GO TO 410 C C TEST FOR CYCLING. C 320 IF (ANORM .LE. ANRM) GO TO 410 C DO 330 I = 1,N ISGN(I) = 1 IF (X(I) .LT. 0.0) ISGN(I) = -1 X(I) = ISGN(I) 330 CONTINUE KASE = 2 JUMP = 4 RETURN C C ................ ENTRY (JUMP = 4) C X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. C 400 JLAST = J J = ISAMAX(N,X,1) IF (X(JLAST) .EQ. ABS(X(J)) .OR. * ITER .GE. ITMAX) GO TO 410 ITER = ITER + 1 GO TO 210 C C ITERATION COMPLETE. FINAL STAGE. C 410 ALTSGN = 1.0 DO 420 I = 1,N X(I) = ALTSGN * (1.0 + FLOAT(I-1)/FLOAT(N-1)) ALTSGN = -ALTSGN 420 CONTINUE KASE = 1 JUMP = 5 RETURN C C ................ ENTRY (JUMP = 5) C X HAS BEEN OVERWRITTEN BY A*X. C 500 ANRM = 2.0*SASUM(N,X,1)/FLOAT(3*N) IF (ANRM .LE. ANORM) GO TO 510 CALL SCOPY (N,X,1,V,1) ANORM = ANRM 510 KASE = 0 RETURN END SUBROUTINE DONEST (N, V, X, ISGN, ANORM, KASE, ITER, J, JUMP) DOUBLE PRECISION ANORM, V(N), X(N) INTEGER ISGN(N) DOUBLE PRECISION ALTSGN, AN, ANM1, ANRM, T DOUBLE PRECISION DASUM C----------------------------------------------------------------------- C C DONEST ESTIMATES THE 1-NORM OF A SQUARE, REAL MATRIX A. C REVERSE COMMUNICATION IS USED FOR EVALUATING C MATRIX-VECTOR PRODUCTS. C C ON ENTRY C C N THE ORDER OF THE MATRIX. N .GE. 1. C C KASE INTEGER (= 0). C C ON INTERMEDIATE RETURNS C C KASE = 1 OR 2. C C X MUST BE OVERWRITTEN BY C C A*X, IF KASE = 1, C TRANSPOSE(A)*X, IF KASE = 2, C C AND DONEST MUST BE RE-CALLED, WITH ALL THE OTHER C PARAMETERS UNCHANGED. C C ITER NUMBER OF THE CURRENT ITERATION. C C ON FINAL RETURN C C KASE = 0. C C ANORM CONTAINS AN ESTIMATE (A LOWER BOUND) FOR NORM(A). C C V = A*W, WHERE ANORM = NORM(V)/NORM(W) C (W IS NOT RETURNED). C C ITER NUMBER OF INTERATIONS TAKEN. C C WRITTEN BY NICK HIGHAM, UNIVERSITY OF MANCHESTER. MODIFIED C BY A.H. MORRIS (NSWC). C C REFERENCE C N.J. HIGHAM (1987) FORTRAN CODES FOR ESTIMATING C THE 1-NORM OF A REAL OR COMPLEX MATRIX, WITH APPLICATIONS C TO CONDITION ESTIMATION, NUMERICAL ANALYSIS REPORT NO. 135, C UNIVERSITY OF MANCHESTER, MANCHESTER M13 9PL, ENGLAND. C C----------------------------------------------------------------------- DATA ITMAX /5/ C AN = N ANM1 = N - 1 IF (KASE .NE. 0) GO TO 20 T = 1.D0/AN DO 10 I = 1,N X(I) = T 10 CONTINUE ITER = 0 KASE = 1 JUMP = 1 RETURN 20 GO TO (100, 200, 300, 400, 500), JUMP C C ................ ENTRY (JUMP = 1) C FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. C 100 ITER = 1 IF (N .GT. 1) GO TO 110 V(1) = X(1) ANORM = DABS(V(1)) GO TO 510 C 110 ANORM = DASUM(N,X,1) DO 120 I = 1,N ISGN(I) = 1 IF (X(I) .LT. 0.D0) ISGN(I) = -1 X(I) = ISGN(I) 120 CONTINUE KASE = 2 JUMP = 2 RETURN C C ................ ENTRY (JUMP = 2) C FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. C 200 ITER = 2 J = IDAMAX(N,X,1) C C MAIN LOOP - ITERATIONS 2,3,...,ITMAX. C 210 DO 220 I = 1,N X(I) = 0.D0 220 CONTINUE X(J) = 1.D0 KASE = 1 JUMP = 3 RETURN C C ................ ENTRY (JUMP = 3) C X HAS BEEN OVERWRITTEN BY A*X. C 300 CALL DCOPY (N,X,1,V,1) ANRM = ANORM ANORM = DASUM(N,V,1) DO 310 I = 1,N L = 1 IF (X(I) .LT. 0.D0) L = -1 IF (L .NE. ISGN(I)) GO TO 320 310 CONTINUE C REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. GO TO 410 C C TEST FOR CYCLING. C 320 IF (ANORM .LE. ANRM) GO TO 410 C DO 330 I = 1,N ISGN(I) = 1 IF (X(I) .LT. 0.D0) ISGN(I) = -1 X(I) = ISGN(I) 330 CONTINUE KASE = 2 JUMP = 4 RETURN C C ................ ENTRY (JUMP = 4) C X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. C 400 JLAST = J J = IDAMAX(N,X,1) IF (X(JLAST) .EQ. DABS(X(J)) .OR. * ITER .GE. ITMAX) GO TO 410 ITER = ITER + 1 GO TO 210 C C ITERATION COMPLETE. FINAL STAGE. C 410 ALTSGN = 1.D0 DO 420 I = 1,N T = I - 1 X(I) = ALTSGN * (1.D0 + T/ANM1) ALTSGN = -ALTSGN 420 CONTINUE KASE = 1 JUMP = 5 RETURN C C ................ ENTRY (JUMP = 5) C X HAS BEEN OVERWRITTEN BY A*X. C 500 ANRM = 2.D0*DASUM(N,X,1)/(3.D0*AN) IF (ANRM .LE. ANORM) GO TO 510 CALL DCOPY (N,X,1,V,1) ANORM = ANRM 510 KASE = 0 RETURN END SUBROUTINE CSPSLV (N,A,IA,JA,B,R,C,MAX,X,ITEMP,RTEMP,IERR) C----------------------------------------------------------------------- C SOLUTION OF COMPLEX SPARSE MATRICES C----------------------------------------------------------------------- C SPSLV CALLS CNSPIV WHICH USES SPARSE GAUSSIAN ELIMINATION WITH C COLUMN INTERCHANGES TO SOLVE THE LINEAR SYSTEM A X = B. THE C ELIMINATION PHASE PERFORMS ROW OPERATIONS ON A AND B TO OBTAIN C A UNIT UPPER TRIANGULAR MATRIX U AND A VECTOR Y. THE SOLUTION C PHASE SOLVES U X = Y. C C INPUT ARGUMENTS--- C C N INTEGER NUMBER OF EQUATIONS AND UNKNOWNS C C A COMPLEX ARRAY WITH ONE ENTRY PER NONZERO IN A, CONTAINING C THE ACTUAL NONZEROS. (SEE STORAGE DESCRIPTION BELOW) C C IA INTEGER ARRAY OF N+1 ENTRIES CONTAINING ROW POINTERS TO A C (SEE MATRIX STORAGE DESCRIPTION BELOW) C C JA INTEGER ARRAY WITH ONE ENTRY PER NONZERO IN A, CONTAINING C COLUMN NUMBERS OF THE NONZEROS OF A. (SEE MATRIX STORAGE C DESCRIPTION BELOW) C C B COMPLEX ARRAY OF N ENTRIES CONTAINING RIGHT HAND SIDE DATA C C R INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF THE C ROWS OF A (I.E., THE ELIMINATION ORDER FOR THE EQUATIONS) C C C INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF THE C COLUMNS OF A. C IS ALSO AN OUTPUT ARGUMENT C C MAX INTEGER NUMBER SPECIFYING MAXIMUM NUMBER OF OFF-DIAGONAL C NONZERO ENTRIES OF U WHICH MAY BE STORED C C ITEMP INTEGER ARRAY OF 3*N + MAX + 2 ENTRIES, FOR INTERNAL USE C C RTEMP COMPLEX ARRAY OF N + MAX ENTRIES FOR INTERNAL USE C C C OUTPUT ARGUMENTS--- C C C INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF THE C COLUMNS OF U. C IS ALSO AN INPUT ARGUMENT C C X COMPLEX ARRAY OF N ENTRIES CONTAINING THE SOLUTION VECTOR C C IERR INTEGER NUMBER WHICH INDICATES ERROR CONDITIONS OR C THE ACTUAL NUMBER OF OFF-DIAGONAL ENTRIES IN U (FOR C SUCCESSFUL COMPLETION) C C IERR VALUES ARE--- C C 0 LT IERR SUCCESSFUL COMPLETION. IERR=MAX(1,M) C WHERE M IS THE NUMBER OF OFF-DIAGONAL C NONZERO ENTRIES OF U. C C IERR = 0 ERROR. N IS LESS THAN OR EQUAL TO 0 C C -N LE IERR LT 0 ERROR. ROW NUMBER IABS(IERR) OF A IS C IS NULL C C -2*N LE IERR LT -N ERROR. ROW NUMBER IABS(IERR+N) HAS A C DUPLICATE ENTRY C C -3*N LE IERR LT -2*N ERROR. ROW NUMBER IABS(IERR+2*N) C HAS A ZERO PIVOT C C -4*N LE IERR LT -3*N ERROR. ROW NUMBER IABS(IERR+3*N) C EXCEEDS STORAGE C C C STORAGE OF SPARSE MATRICES--- C C THE SPARSE MATRIX A IS STORED USING THREE ARRAYS IA, JA, AND A. C THE ARRAY A CONTAINS THE NONZEROS OF THE MATRIX ROW-BY-ROW, NOT C NECESSARILY IN ORDER OF INCREASING COLUMN NUMBER. THE ARRAY JA C CONTAINS THE COLUMN NUMBERS CORRESPONDING TO THE NONZEROS STORED C IN THE ARRAY A (I.E., IF THE NONZERO STORED IN A(K) IS IN C COLUMN J, THEN JA(K) = J). THE ARRAY IA CONTAINS POINTERS TO THE C ROWS OF NONZEROS/COLUMN INDICES IN THE ARRAY A/JA (I.E., C A(IA(I))/JA(IA(I)) IS THE FIRST ENTRY FOR ROW I IN THE ARRAY A/JA). C IA(N+1) IS SET SO THAT IA(N+1) - IA(1) = THE NUMBER OF NONZERO C ELEMENTS IN A. C------------------------ COMPLEX A(*), B(N), X(N), RTEMP(*) INTEGER IA(*), JA(*), R(N), C(N), ITEMP(*) INTEGER IU, JU, U, Y, P C IERR = 0 IF (N .LE. 0) RETURN C C SET INDICES TO DIVIDE TEMPORARY STORAGE FOR CNSPIV C Y = 1 U = Y + N P = N + 1 IU = P + N + 1 JU = IU + N + 1 C C COMPUTE THE INVERSE PERMUTATION OF C C DO 10 K = 1,N L = C(K) ITEMP(L) = K 10 CONTINUE C C CALL CNSPIV TO PERFORM COMPUTATIONS C CALL CNSPIV (N,IA,JA,A,B,MAX,R,C,ITEMP(1),X,RTEMP(Y),ITEMP(P), * ITEMP(IU),ITEMP(JU),RTEMP(U),IERR) IF (IERR .EQ. 0) IERR = 1 RETURN END SUBROUTINE CNSPIV (N,IA,JA,A,B,MAX,R,C,IC,X,Y,P,IU,JU,U,IERR) C C C CNSPIV USES SPARSE GAUSSIAN ELIMINATION WITH C COLUMN INTERCHANGES TO SOLVE THE LINEAR SYSTEM A X = B. THE C ELIMINATION PHASE PERFORMS ROW OPERATIONS ON A AND B TO OBTAIN C A UNIT UPPER TRIANGULAR MATRIX U AND A VECTOR Y. THE SOLUTION C PHASE SOLVES U X = Y. C C C SEE CSPSLV FOR DESCRIPTIONS OF ALL INPUT AND OUTPUT ARGUMENTS C OTHER THAN THOSE DESCRIBED BELOW C C IC INTEGER ARRAY OF N ENTRIES WHICH IS THE INVERSE OF C C (I.E., IC(C(I)) = I). IC IS BOTH AN INPUT AND OUTPUT C ARGUMENT. C C INPUT ARGUMENTS (USED INTERNALLY ONLY)--- C C Y COMPLEX ARRAY OF N ENTRIES USED TO COMPUTE THE UPDATED C RIGHT HAND SIDE C C P INTEGER ARRAY OF N+1 ENTRIES USED FOR A LINKED LIST. C P(N+1) IS THE LIST HEADER, AND THE ENTRY FOLLOWING C P(K) IS IN P(P(K)). THUS, P(N+1) IS THE FIRST DATA C ITEM, P(P(N+1)) IS THE SECOND, ETC. A POINTER OF C N+1 MARKS THE END OF THE LIST C C IU INTEGER ARRAY OF N+1 ENTRIES USED FOR ROW POINTERS TO U C (SEE MATRIX STORAGE DESCRIPTION BELOW) C C JU INTEGER ARRAY OF MAX ENTRIES USED FOR COLUMN NUMBERS OF C THE NONZEROS IN THE STRICT UPPER TRIANGLE OF U. (SEE C MATRIX STORAGE DESCRIPTION BELOW) C C U COMPLEX ARRAY OF MAX ENTRIES USED FOR THE ACTUAL NONZEROS IN C THE STRICT UPPER TRIANGLE OF U. (SEE MATRIX STORAGE C DESCRIPTION BELOW) C C C STORAGE OF SPARSE MATRICES--- C C THE SPARSE MATRIX A IS STORED USING THREE ARRAYS IA, JA, AND A. C THE ARRAY A CONTAINS THE NONZEROS OF THE MATRIX ROW-BY-ROW, NOT C NECESSARILY IN ORDER OF INCREASING COLUMN NUMBER. THE ARRAY JA C CONTAINS THE COLUMN NUMBERS CORRESPONDING TO THE NONZEROS STORED C IN THE ARRAY A (I.E., IF THE NONZERO STORED IN A(K) IS IN C COLUMN J, THEN JA(K) = J). THE ARRAY IA CONTAINS POINTERS TO THE C ROWS OF NONZEROS/COLUMN INDICES IN THE ARRAY A/JA (I.E., C A(IA(I))/JA(IA(I)) IS THE FIRST ENTRY FOR ROW I IN THE ARRAY A/JA). C IA(N+1) IS SET SO THAT IA(N+1) - IA(1) = THE NUMBER OF NONZEROS IN C A. IU, JU, AND U ARE USED IN A SIMILAR WAY TO STORE THE STRICT UPPER C TRIANGLE OF U, EXCEPT THAT JU ACTUALLY CONTAINS C(J) INSTEAD OF J C C COMPLEX A(*), B(N), U(MAX), X(N), Y(N) COMPLEX DK, LKI, ONE, YK, ZERO REAL XPV, XPVMAX INTEGER C(N), IA(*), IC(N), IU(*), JA(*), JU(MAX), P(*), R(N) INTEGER CK, PK, PPK, PV, V, VI, VJ, VK C ONE = (1.0,0.0) ZERO = (0.0,0.0) C C INITIALIZE WORK STORAGE AND POINTERS TO JU C DO 10 J = 1,N X(J) = ZERO 10 CONTINUE IU(1) = 1 JUPTR = 0 C C PERFORM SYMBOLIC AND NUMERIC FACTORIZATION ROW BY ROW C VK (VI,VJ) IS THE GRAPH VERTEX FOR ROW K (I,J) OF U C DO 170 K = 1,N C C INITIALIZE LINKED LIST AND FREE STORAGE FOR THIS ROW C THE R(K)-TH ROW OF A BECOMES THE K-TH ROW OF U. C P(N+1) = N+1 VK = R(K) C C SET UP ADJACENCY LIST FOR VK, ORDERED IN C CURRENT COLUMN ORDER OF U. THE LOOP INDEX C GOES DOWNWARD TO EXPLOIT ANY COLUMNS C FROM A IN CORRECT RELATIVE ORDER C JMIN = IA(VK) JMAX = IA(VK+1) - 1 IF (JMIN .GT. JMAX) GO TO 1002 J = JMAX 20 JAJ = JA(J) VJ = IC(JAJ) C C STORE A(K,J) IN WORK VECTOR C X(VJ) = A(J) C THIS CODE INSERTS VJ INTO ADJACENCY LIST OF VK PPK = N+1 30 PK = PPK PPK = P(PK) IF (PPK - VJ) 30,1003,40 40 P(VJ) = PPK P(PK) = VJ J = J - 1 IF (J .GE. JMIN) GO TO 20 C C THE FOLLOWING CODE COMPUTES THE K-TH ROW OF U C VI = N+1 YK = B(VK) 50 VI = P(VI) IF (VI .GE. K) GO TO 110 C C VI LT VK -- PROCESS THE L(K,I) ELEMENT AND MERGE THE C ADJACENCY OF VI WITH THE ORDERED ADJACENCY OF VK C LKI = - X(VI) X(VI) = ZERO C C ADJUST RIGHT HAND SIDE TO REFLECT ELIMINATION C YK = YK + LKI * Y(VI) PPK = VI JMIN = IU(VI) JMAX = IU(VI+1) - 1 IF (JMIN .GT. JMAX) GO TO 50 DO 100 J = JMIN,JMAX JUJ = JU(J) VJ = IC(JUJ) C C IF VJ IS ALREADY IN THE ADJACENCY OF VK, C SKIP THE INSERTION C IF (X(VJ) .NE. ZERO) GO TO 90 C C INSERT VJ IN ADJACENCY LIST OF VK. C RESET PPK TO VI IF WE HAVE PASSED THE CORRECT C INSERTION SPOT. (THIS HAPPENS WHEN THE ADJACENCY OF C VI IS NOT IN CURRENT COLUMN ORDER DUE TO PIVOTING.) C IF (VJ - PPK) 60,90,70 60 PPK = VI 70 PK = PPK PPK = P(PK) IF (PPK - VJ) 70,90,80 80 P(VJ) = PPK P(PK) = VJ PPK = VJ C C COMPUTE L(K,J) = L(K,J) - L(K,I)*U(I,J) FOR L(K,I) NONZERO C COMPUTE U*(K,J) = U*(K,J) - L(K,I)*U(I,J) FOR U(K,J) NONZERO C (U*(K,J) = U(K,J)*D(K,K)) C 90 X(VJ) = X(VJ) + LKI * U(J) 100 CONTINUE GO TO 50 C C PIVOT--INTERCHANGE LARGEST ENTRY OF K-TH ROW OF U WITH C THE DIAGONAL ENTRY. C C FIND LARGEST ENTRY, COUNTING OFF-DIAGONAL NONZEROS C 110 IF (VI .GT. N) GO TO 1004 XPVMAX = ABS(REAL(X(VI))) + ABS(AIMAG(X(VI))) MAXC = VI NZCNT = 0 PV = VI 120 V = PV PV = P(PV) IF (PV .GT. N) GO TO 130 NZCNT = NZCNT + 1 XPV = ABS(REAL(X(PV))) + ABS(AIMAG(X(PV))) IF (XPV .LE. XPVMAX) GO TO 120 XPVMAX = XPV MAXC = PV MAXCL = V GO TO 120 130 IF (XPVMAX .EQ. 0.0) GO TO 1004 C C IF VI = K, THEN THERE IS AN ENTRY FOR DIAGONAL C WHICH MUST BE DELETED. OTHERWISE, DELETE THE C ENTRY WHICH WILL BECOME THE DIAGONAL ENTRY C IF (VI .EQ. K) GO TO 140 IF (VI .EQ. MAXC) GO TO 140 P(MAXCL) = P(MAXC) GO TO 150 140 VI = P(VI) C C COMPUTE D(K) = 1/L(K,K) AND PERFORM INTERCHANGE. C 150 DK = ONE / X(MAXC) X(MAXC) = X(K) I = C(K) C(K) = C(MAXC) C(MAXC) = I CK = C(K) IC(CK) = K IC(I) = MAXC X(K) = ZERO C C UPDATE RIGHT HAND SIDE. C Y(K) = YK * DK C C COMPUTE VALUE FOR IU(K+1) AND CHECK FOR STORAGE OVERFLOW C IU(K+1) = IU(K) + NZCNT IF (IU(K+1) .GT. MAX+1) GO TO 1005 C C MOVE COLUMN INDICES FROM LINKED LIST TO JU. C COLUMNS ARE STORED IN CURRENT ORDER WITH ORIGINAL C COLUMN NUMBER (C(J)) STORED FOR CURRENT COLUMN J C IF (VI .GT. N) GO TO 170 J = VI 160 JUPTR = JUPTR + 1 JU(JUPTR) = C(J) U(JUPTR) = X(J) * DK X(J) = ZERO J = P(J) IF (J .LE. N) GO TO 160 170 CONTINUE C C BACKSOLVE U X = Y, AND REORDER X TO CORRESPOND WITH A C K = N DO 200 I = 1,N YK = Y(K) JMIN = IU(K) JMAX = IU(K+1) - 1 IF (JMIN .GT. JMAX) GO TO 190 DO 180 J = JMIN,JMAX JUJ = JU(J) JUJ = IC(JUJ) YK = YK - U(J) * Y(JUJ) 180 CONTINUE 190 Y(K) = YK CK = C(K) X(CK) = YK K = K - 1 200 CONTINUE C C RETURN WITH IERR = NUMBER OF OFF-DIAGONAL NONZEROS IN U C IERR = IU(N+1) - IU(1) RETURN C C ERROR RETURNS C C ROW K OF A IS NULL C 1002 IERR = -K RETURN C C ROW K OF A HAS A DUPLICATE ENTRY C 1003 IERR = -(N+K) RETURN C C ZERO PIVOT IN ROW K C 1004 IERR = -(2*N+K) RETURN C C STORAGE FOR U EXCEEDED ON ROW K C 1005 IERR = -(3*N+K) RETURN END SUBROUTINE CSLV (M0,N,A,IA,JA,B,R,C,MAX,X,IWK,WK,IERR) C----------------------------------------------------------------------- C SOLUTION OF COMPLEX SPARSE MATRICES C----------------------------------------------------------------------- C CSLV EMPLOYS GAUSSIAN ELIMINATION WITH COLUMN INTERCHANGES TO C SOLVE THE NXN COMPLEX SYSTEM AX = B. THE ARGUMENT M0 SPECIFIES C IF CSLV IS BEING CALLED FOR THE FIRST TIME, OR IF IT IS BEING C RECALLED WHERE A IS THE SAME MATRIX BUT B HAS BEEN MODIFIED. C ON AN INITIAL CALL TO THE ROUTINE (WHEN M0=0) THE LU DECOMPO- C SITION OF A IS OBTAINED WHERE U IS A UNIT UPPER TRIANGULAR C MATRIX. THEN THE EQUATIONS ARE SOLVED. ON SUBSEQUENT CALLS C (WHEN M0.NE.0) THE EQUATIONS ARE SOLVED USING THE DECOMPOSITION C OBTAINED ON THE INITIAL CALL TO CSLV. C C C INPUT ARGUMENTS WHEN M0=0 --- C C N NUMBER OF EQUATIONS AND UNKNOWNS. C C A,IA,JA THE COMPLEX MATRIX A STORED IN SPARSE FORM. C C B COMPLEX ARRAY OF N ENTRIES CONTAINING THE RIGHT HAND C SIDE DATA. C C R INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF C THE ROWS OF A. C C C INTEGER ARRAY OF N ENTRIES SPECIFYING A SUGGESTED C ORDER OF THE COLUMNS. C IS ALSO AN OUTPUT ARGUMENT. C C MAX INTEGER SPECIFYING THE MAXIMUM NUMBER OF OFF-DIAGONAL C NONZERO ENTRIES OF L AND U WHICH MAY BE STORED. C C C OUTPUT ARGUMENTS WHEN M0=0 --- C C C INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF C THE COLUMNS THAT WAS SELECTED BY THE ROUTINE. C C X COMPLEX ARRAY OF N ENTRIES CONTAINING THE SOLUTION. C B AND X MAY SHARE THE SAME STORAGE AREA. C C IERR INTEGER SPECIFYING THE STATUS OF THE RESULTS. IF THE C SOLUTION OF AX = B IS OBTAINED THEN IERR = MAX(1,M) C WHERE M IS THE TOTAL NUMBER OF OFF-DIAGONAL NONZERO C ENTRIES OF L AND U. OTHERWISE IERR.LE.0. C C C GENERAL STORAGE AREAS --- C C IWK INTEGER ARRAY OF DIMENSION 4*N + MAX + 2. C C WK COMPLEX ARRAY OF DIMENSION 2*N + MAX. C C C AFTER AN INITIAL CALL TO CSLV, THE ROUTINE MAY BE RECALLED WITH C M0.NE.0 FOR A NEW B. WHEN M0.NE.0 IT IS ASSUMED THAT N,A,IA,JA, C R,C,IWK,WK HAVE NOT BEEN MODIFIED. THE ROUTINE RETRIEVES THE LU C DECOMPOSITION WHICH WAS OBTAINED ON THE INITIAL CALL TO CSLV C AND SOLVES THE NEW EQUATIONS AX = B. IN THIS CASE A,IA,JA,MAX, C AND IERR ARE NOT REFERENCED. C----------------------------------------------------------------------- COMPLEX A(*), B(N), X(N), WK(*) INTEGER IA(*), JA(*), IWK(*) INTEGER R(N), C(N), Y, T, P C C SET INDICES TO DIVIDE TEMPORARY STORAGE C Y = N + 1 T = Y + N P = N + 1 IT = P + N + 1 IU = IT + N + 1 JT = IU + N IF (M0 .NE. 0) GO TO 20 C C COMPUTE THE INVERSE PERMUTATION OF C C IERR = 0 IF (N .LE. 0) RETURN DO 10 K = 1,N L = C(K) IWK(L) = K 10 CONTINUE C C OBTAIN THE LU DECOMPOSITION OF A C CALL CSPLU (A,IA,JA,R,C,IWK(1),N,MAX,WK(1),WK(T),IWK(IT),IWK(JT), * IWK(IU),WK(Y),IWK(P),IERR) IF (IERR .LT. 0) RETURN IERR = MAX0(1,IERR) C C SOLVE THE SYSTEM OF EQUATIONS C 20 CALL CSLV1 (N,R,C,IWK(1),WK(1),WK(T),IWK(IT),IWK(JT),IWK(IU), * B,X,WK(Y)) RETURN END SUBROUTINE CSLV1 (N,R,C,IC,D,T,IT,JT,IU,B,X,Y) INTEGER R(N), C(N), IC(N) INTEGER IT(*), JT(*), IU(N) COMPLEX B(N), D(N), T(*), X(N), Y(N), SUM C C SOLVE LY = B BY FORWARD SUBSTITUTION C DO 11 K = 1,N LK = R(K) SUM = B(LK) JMIN = IT(K) JMAX = IU(K) - 1 IF (JMIN .GT. JMAX) GO TO 11 DO 10 JJ = JMIN,JMAX LJ = JT(JJ) J = IC(LJ) SUM = SUM - T(JJ)*Y(J) 10 CONTINUE 11 Y(K) = SUM/D(K) C C SOLVE UX = B BY BACKWARD SUBSTITUTION C AND REORDER X TO CORRESPOND WITH A C K = N DO 22 I = 1,N SUM = Y(K) JMIN = IU(K) JMAX = IT(K+1) - 1 IF (JMIN .GT. JMAX) GO TO 21 DO 20 JJ = JMIN,JMAX LJ = JT(JJ) J = IC(LJ) SUM = SUM - T(JJ)*Y(J) 20 CONTINUE 21 Y(K) = SUM LK = C(K) X(LK) = Y(K) K = K - 1 22 CONTINUE RETURN END SUBROUTINE CTSLV (M0,N,A,IA,JA,B,R,C,MAX,X,IWK,WK,IERR) C----------------------------------------------------------------------- C SOLUTION OF COMPLEX SPARSE MATRICES C----------------------------------------------------------------------- C CTSLV EMPLOYS GAUSSIAN ELIMINATION WITH COLUMN INTERCHANGES TO C SOLVE THE NXN COMPLEX SYSTEM XA = B. THE ARGUMENT M0 SPECIFIES C IF CTSLV IS BEING CALLED FOR THE FIRST TIME, OR IF IT IS BEING C RECALLED WHERE A IS THE SAME MATRIX BUT B HAS BEEN MODIFIED. C ON AN INITIAL CALL TO THE ROUTINE (WHEN M0=0) THE LU DECOMPO- C SITION OF A IS OBTAINED WHERE U IS A UNIT UPPER TRIANGULAR C MATRIX. THEN THE EQUATIONS ARE SOLVED. ON SUBSEQUENT CALLS C (WHEN M0.NE.0) THE EQUATIONS ARE SOLVED USING THE DECOMPOSITION C OBTAINED ON THE INITIAL CALL TO CTSLV. C C C INPUT ARGUMENTS WHEN M0=0 --- C C N NUMBER OF EQUATIONS AND UNKNOWNS. C C A,IA,JA THE COMPLEX MATRIX A STORED IN SPARSE FORM. C C B COMPLEX ARRAY OF N ENTRIES CONTAINING THE RIGHT HAND C SIDE DATA. C C R INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF C THE ROWS OF A. C C C INTEGER ARRAY OF N ENTRIES SPECIFYING A SUGGESTED C ORDER OF THE COLUMNS. C IS ALSO AN OUTPUT ARGUMENT. C C MAX INTEGER SPECIFYING THE MAXIMUM NUMBER OF OFF-DIAGONAL C NONZERO ENTRIES OF L AND U WHICH MAY BE STORED. C C C OUTPUT ARGUMENTS WHEN M0=0 --- C C C INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF C THE COLUMNS THAT WAS SELECTED BY THE ROUTINE. C C X COMPLEX ARRAY OF N ENTRIES CONTAINING THE SOLUTION. C B AND X MAY SHARE THE SAME STORAGE AREA. C C IERR INTEGER SPECIFYING THE STATUS OF THE RESULTS. IF THE C SOLUTION OF AX = B IS OBTAINED THEN IERR = MAX(1,M) C WHERE M IS THE TOTAL NUMBER OF OFF-DIAGONAL NONZERO C ENTRIES OF L AND U. OTHERWISE IERR.LE.0. C C C GENERAL STORAGE AREAS --- C C IWK INTEGER ARRAY OF DIMENSION 4*N + MAX + 2. C C WK COMPLEX ARRAY OF DIMENSION 2*N + MAX. C C C AFTER AN INITIAL CALL TO CTSLV, THE ROUTINE MAY BE RECALLED WITH C M0.NE.0 FOR A NEW B. WHEN M0.NE.0 IT IS ASSUMED THAT N,A,IA,JA, C R,C,IWK,WK HAVE NOT BEEN MODIFIED. THE ROUTINE RETRIEVES THE LU C DECOMPOSITION WHICH WAS OBTAINED ON THE INITIAL CALL TO CTSLV C AND SOLVES THE NEW EQUATIONS XA = B. IN THIS CASE A,IA,JA,MAX, C AND IERR ARE NOT REFERENCED. C----------------------------------------------------------------------- COMPLEX A(*), B(N), X(N), WK(*) INTEGER IA(*), JA(*), IWK(*) INTEGER R(N), C(N), Y, T, P C C SET INDICES TO DIVIDE TEMPORARY STORAGE C Y = N + 1 T = Y + N P = N + 1 IT = P + N + 1 IU = IT + N + 1 JT = IU + N IF (M0 .NE. 0) GO TO 20 C C COMPUTE THE INVERSE PERMUTATION OF C C IERR = 0 IF (N .LE. 0) RETURN DO 10 K = 1,N L = C(K) IWK(L) = K 10 CONTINUE C C OBTAIN THE LU DECOMPOSITION OF A C CALL CSPLU (A,IA,JA,R,C,IWK(1),N,MAX,WK(1),WK(T),IWK(IT),IWK(JT), * IWK(IU),WK(Y),IWK(P),IERR) IF (IERR .LT. 0) RETURN IERR = MAX0(1,IERR) C C SOLVE THE SYSTEM OF EQUATIONS C 20 CALL CTSLV1 (N,R,C,IWK(1),WK(1),WK(T),IWK(IT),IWK(JT),IWK(IU), * B,X,WK(Y)) RETURN END SUBROUTINE CTSLV1 (N,R,C,IC,D,T,IT,JT,IU,B,X,Y) INTEGER R(N), C(N), IC(N) INTEGER IT(*), JT(*), IU(N) COMPLEX B(N), D(N), T(*), X(N), Y(N) C C SOLVE YU = B BY FORWARD SUBSTITUTION C DO 10 K = 1,N LK = C(K) Y(K) = B(LK) 10 CONTINUE C DO 21 K = 1,N IF (Y(K) .EQ. (0.0, 0.0)) GO TO 21 JMIN = IU(K) JMAX = IT(K+1) - 1 IF (JMIN .GT. JMAX) GO TO 21 DO 20 JJ = JMIN,JMAX LJ = JT(JJ) J = IC(LJ) Y(J) = Y(J) - T(JJ)*Y(K) 20 CONTINUE 21 CONTINUE C C SOLVE XL = Y BY BACKWARD SUBSTITUTION C X(N) = Y(N)/D(N) IF (N .EQ. 1) RETURN C K = N Y(N) = X(N) DO 32 I = 2,N JMIN = IT(K) JMAX = IU(K) - 1 IF (JMIN .GT. JMAX) GO TO 31 DO 30 JJ = JMIN,JMAX LJ = JT(JJ) J = IC(LJ) Y(J) = Y(J) - T(JJ)*Y(K) 30 CONTINUE 31 K = K - 1 Y(K) = Y(K)/D(K) 32 CONTINUE C DO 40 K = 1,N LK = R(K) X(LK) = Y(K) 40 CONTINUE RETURN END SUBROUTINE CSPLU (A,IA,JA,R,C,IC,N,MAX,D,T,IT,JT,IU,W,P,IERR) C----------------------------------------------------------------------- C CSPLU EMPLOYS GAUSSIAN ELIMINATION WITH COLUMN INTERCHANGES C TO PERFORM THE LU DECOMPOSITION OF A COMPLEX SPARSE MATRIX. C U IS A UNIT UPPER TRIANGULAR MATRIX. C C C INPUT ARGUMENTS --- C C A,IA,JA THE COMPLEX SPARSE MATRIX TO BE DECOMPOSED. C C R INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF C THE ROWS OF A. C C C INTEGER ARRAY OF N ENTRIES SPECIFYING A SUGGESTED C ORDER OF THE COLUMNS. C IS ALSO AN OUTPUT ARGUMENT. C C IC INTEGER ARRAY OF N ENTRIES WHICH IS THE INVERSE OF C C (I.E., IC(C(I)) = I). IC IS ALSO AN OUTPUT ARGUMENT. C C N ORDER OF THE MATRIX A. C C MAX INTEGER SPECIFYING THE MAXIMUM NUMBER OF OFF-DIAGONAL C NONZERO ENTRIES OF L AND U WHICH MAY BE STORED. C C C OUTPUT ARGUMENTS --- C C C INTEGER ARRAY OF N ENTRIES SPECIFYING THE ORDER OF C THE COLUMNS THAT WAS SELECTED BY THE ROUTINE. C C IC INTEGER ARRAY OF N ENTRIES WHICH IS THE INVERSE OF C. C C D COMPLEX ARRAY CONTAINING THE N DIAGONAL ELEMENTS OF L. C C T,IT,IU T CONTAINS THE OFF-DIAGONAL NONZERO ELEMENTS OF L AND C U. FOR I = 1,...,N THE OFF-DIAGONAL NONZERO ELEMENTS C OF THE I-TH ROW OF L ARE STORED IN LOCATIONS C IT(I),...,IU(I)-1 OF T, AND THE OFF-DIAGONAL NONZERO C ELEMENTS OF THE I-TH ROW OF U ARE STORED IN LOCATIONS C IU(I),...,IT(I+1)-1 OF T. T IS A COMPLEX ARRAY. C C JT INTEGER ARRAY CONTAINING THE COLUMN INDICES (ACCORDING C TO THE ORGINAL COLUMN ORDERING) OF THE ELEMENTS OF T C (I.E., FOR EACH L(I,J) AND U(I,J) IN T, C(J) IS THE C CORRESPONDING COLUMN INDEX IN JT). C C IERR INTEGER SPECIFYING THE STATUS OF THE RESULTS. IF THE C LU DECOMPOSITION IS OBTAINED THEN IERR = THE NUMBER C OF OFF-DIAGONAL ENTRIES OF L AND U WHICH WERE STORED C IN T. OTHERWISE IERR IS ASSIGNED A NEGATIVE VALUE. C C C WORK SPACES --- C C W COMPLEX ARRAY OF DIMENSION N. C C P INTEGER ARRAY OF DIMENSION N+1. C----------------------------------------------------------------------- COMPLEX A(*), D(N), T(MAX), W(N) INTEGER IA(*), JA(*) INTEGER R(N), C(N), IC(N) INTEGER IT(*), JT(MAX), IU(N) INTEGER P(*), PM COMPLEX CONST, ZERO REAL WI, WMAX C-------------------- DATA ZERO /(0.0, 0.0)/ C-------------------- JPTR = 0 IT(1) = 1 DO 10 J = 1,N W(J) = ZERO 10 CONTINUE C C PERFORM THE LU FACTORIZATION OF THE R(K)-TH ROW OF A C DO 100 K = 1,N LK = R(K) JMIN = IA(LK) JMAX = IA(LK+1) - 1 IF (JMIN .GT. JMAX) GO TO 200 C C SET P TO THE REORDERED ROW OF A C P(N+1) = N + 1 JJ = JMAX 20 LJ = JA(JJ) J = IC(LJ) W(J) = A(JJ) PM = N + 1 21 M = PM PM = P(M) IF (PM - J) 21,210,22 22 P(M) = J P(J) = PM JJ = JJ - 1 IF (JJ .GE. JMIN) GO TO 20 C C PROCESS THE ENTRIES IN THE LOWER TRIANGLE OF A C I = N + 1 30 I = P(I) IF (I .GE. K) GO TO 50 IF (W(I) .EQ. ZERO) GO TO 30 C C L(K,I) IS NONZERO. THEREFORE STORE IT IN L. C JPTR = JPTR + 1 IF (JPTR .GT. MAX) GO TO 230 CONST = W(I) T(JPTR) = CONST JT(JPTR) = C(I) W(I) = ZERO C C PERFORM ELIMINATION USING THE I-TH ROW OF U C JMIN = IU(I) JMAX = IT(I+1) - 1 IF (JMIN .GT. JMAX) GO TO 30 PM = I DO 43 JJ = JMIN,JMAX LJ = JT(JJ) J = IC(LJ) IF (W(J) .NE. ZERO) GO TO 43 IF (J - PM) 40,43,41 40 PM = I 41 M = PM PM = P(M) IF (PM - J) 41,43,42 42 P(M) = J P(J) = PM PM = J 43 W(J) = W(J) - CONST*T(JJ) GO TO 30 C C SEARCH FOR THE K-TH PIVOT ELEMENT C 50 IF (I .GT. N) GO TO 220 WMAX = ABS(REAL(W(I))) + ABS(AIMAG(W(I))) MAXI = I PM = I 51 M = PM PM = P(M) IF (PM .GT. N) GO TO 60 WI = ABS(REAL(W(PM))) + ABS(AIMAG(W(PM))) IF (WI .LE. WMAX) GO TO 51 WMAX = WI MAXI = PM MAXIL = M GO TO 51 C C STORE THE PIVOT IN D C 60 IF (WMAX .EQ. 0.0) GO TO 220 D(K) = W(MAXI) C C PERFORM THE COLUMN INTERCHANGE C IF (I .EQ. K) GO TO 70 IF (I .EQ. MAXI) GO TO 70 P(MAXIL) = P(MAXI) GO TO 80 70 I = P(I) C 80 W(MAXI) = W(K) W(K) = ZERO LK = C(K) LL = C(MAXI) C(K) = LL C(MAXI) = LK IC(LK) = MAXI IC(LL) = K C C THE REMAINING ELEMENTS OF P FORM THE K-TH ROW OF U C IU(K) = JPTR + 1 90 IF (I .GT. N) GO TO 100 IF (W(I) .EQ. ZERO) GO TO 91 JPTR = JPTR + 1 IF (JPTR .GT. MAX) GO TO 230 T(JPTR) = W(I)/D(K) JT(JPTR) = C(I) W(I) = ZERO 91 I = P(I) GO TO 90 C C PREPARE FOR THE NEXT ROW C 100 IT(K+1) = JPTR + 1 C IERR = JPTR RETURN C C -------------------- ERROR RETURN -------------------- C C ROW R(K) IS NULL C 200 IERR = -K RETURN C C ROW R(K) HAS A DUPLICATE ENTRY C 210 IERR = -(N + K) RETURN C C ZERO PIVOT IN ROW R(K) C 220 IERR = -(2*N + K) RETURN C C STORAGE FOR L AND U EXCEEDED ON ROW R(K) C 230 IERR = -(3*N + K) RETURN END SUBROUTINE EIG (IBAL,A,KA,N,WR,WI,IERR) C----------------------------------------------------------------------- C EIGENVALUES OF REAL MATRICES C----------------------------------------------------------------------- REAL A(KA,N), WR(N), WI(N) C LOW = 1 IGH = N IF (IBAL .NE. 0) CALL BALANC (KA,N,A,LOW,IGH,WR) CALL ELMHS0 (KA,N,LOW,IGH,A,WR) CALL HQR (KA,N,LOW,IGH,A,WR,WI,IERR) RETURN END SUBROUTINE EIG1 (IBAL,A,KA,N,WR,WI,IERR) C----------------------------------------------------------------------- C EIGENVALUES OF REAL MATRICES C----------------------------------------------------------------------- REAL A(KA,N), WR(N), WI(N) C LOW = 1 IGH = N IF (IBAL .NE. 0) CALL BALANC (KA,N,A,LOW,IGH,WR) CALL ORTHES (KA,N,LOW,IGH,A,WR) CALL HQR (KA,N,LOW,IGH,A,WR,WI,IERR) RETURN END SUBROUTINE EIGV (IBAL,A,KA,N,WR,WI,ZR,ZI,IERR) C----------------------------------------------------------------------- C EIGENVALUES AND EIGENVECTORS OF REAL MATRICES C----------------------------------------------------------------------- REAL A(KA,N), WR(N), WI(N), ZR(KA,N), ZI(KA,N) C LOW = 1 IGH = N IF (IBAL .NE. 0) CALL BALANC (KA,N,A,LOW,IGH,ZI) CALL ELMHS0 (KA,N,LOW,IGH,A,WR) CALL ELTRN0 (KA,N,LOW,IGH,A,WR,ZR) CALL HQR2 (KA,N,LOW,IGH,A,WR,WI,ZR,IERR) IF (IERR .NE. 0) RETURN IF (IBAL .NE. 0) CALL BALBAK (KA,N,LOW,IGH,ZI,N,ZR) C DO 30 K = 1,N IF (WI(K)) 30,10,20 10 DO 11 J = 1,N 11 ZI(J,K) = 0.0 GO TO 30 20 KP1 = K + 1 DO 21 J = 1,N ZI(J,K) = ZR(J,KP1) ZR(J,KP1) = ZR(J,K) 21 ZI(J,KP1) = -ZI(J,K) 30 CONTINUE RETURN END SUBROUTINE EIGV1 (IBAL,A,KA,N,WR,WI,ZR,ZI,IERR) C----------------------------------------------------------------------- C EIGENVALUES AND EIGENVECTORS OF REAL MATRICES C----------------------------------------------------------------------- REAL A(KA,N), WR(N), WI(N), ZR(KA,N), ZI(KA,N) C LOW = 1 IGH = N IF (IBAL .NE. 0) CALL BALANC (KA,N,A,LOW,IGH,ZI) CALL ORTHES (KA,N,LOW,IGH,A,WR) CALL ORTRAN (KA,N,LOW,IGH,A,WR,ZR) CALL HQR2 (KA,N,LOW,IGH,A,WR,WI,ZR,IERR) IF (IERR .NE. 0) RETURN IF (IBAL .NE. 0) CALL BALBAK (KA,N,LOW,IGH,ZI,N,ZR) C DO 30 K = 1,N IF (WI(K)) 30,10,20 10 DO 11 J = 1,N 11 ZI(J,K) = 0.0 GO TO 30 20 KP1 = K + 1 DO 21 J = 1,N ZI(J,K) = ZR(J,KP1) ZR(J,KP1) = ZR(J,K) 21 ZI(J,KP1) = -ZI(J,K) 30 CONTINUE RETURN END SUBROUTINE BALANC(NM,N,A,LOW,IGH,SCALE) C INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC REAL A(NM,N),SCALE(N) REAL C,F,G,R,S,B2,RADIX INTEGER IPMPAR C REAL ABS LOGICAL NOCONV C----------------------------------------------------------------------- C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BALANCE, C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). C C THIS SUBROUTINE BALANCES A REAL MATRIX AND ISOLATES C EIGENVALUES WHENEVER POSSIBLE. C C ON INPUT- C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C N IS THE ORDER OF THE MATRIX, C C A CONTAINS THE INPUT MATRIX TO BE BALANCED. C C ON OUTPUT- C C A CONTAINS THE BALANCED MATRIX, C C LOW AND IGH ARE TWO INTEGERS SUCH THAT A(I,J) C IS EQUAL TO ZERO IF C (1) I IS GREATER THAN J AND C (2) J=1,...,LOW-1 OR I=IGH+1,...,N, C C SCALE CONTAINS INFORMATION DETERMINING THE C PERMUTATIONS AND SCALING FACTORS USED. C C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN C SCALE(J) = P(J), FOR J = 1,...,LOW-1 C = D(J,J), J = LOW,...,IGH C = P(J) J = IGH+1,...,N. C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1, C THEN 1 TO LOW-1. C C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY. C C THE ALGOL PROCEDURE EXC CONTAINED IN BALANCE APPEARS IN C BALANC IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS C K,L HAVE BEEN REVERSED.) C C----------------------------------------------------------------------- C C ********** RADIX IS A MACHINE DEPENDENT PARAMETER SPECIFYING C THE BASE OF THE MACHINE FLOATING POINT REPRESENTATION. C RADIX = IPMPAR(4) C C ********** C B2 = RADIX * RADIX K = 1 L = N GO TO 100 C ********** IN-LINE PROCEDURE FOR ROW AND C COLUMN EXCHANGE ********** 20 SCALE(M) = J IF (J .EQ. M) GO TO 50 C DO 30 I = 1, L F = A(I,J) A(I,J) = A(I,M) A(I,M) = F 30 CONTINUE C DO 40 I = K, N F = A(J,I) A(J,I) = A(M,I) A(M,I) = F 40 CONTINUE C 50 GO TO (80,130), IEXC C ********** SEARCH FOR ROWS ISOLATING AN EIGENVALUE C AND PUSH THEM DOWN ********** 80 IF (L .EQ. 1) GO TO 280 L = L - 1 C ********** FOR J=L STEP -1 UNTIL 1 DO -- ********** 100 DO 120 JJ = 1, L J = L + 1 - JJ C DO 110 I = 1, L IF (I .EQ. J) GO TO 110 IF (A(J,I) .NE. 0.0) GO TO 120 110 CONTINUE C M = L IEXC = 1 GO TO 20 120 CONTINUE C GO TO 140 C ********** SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE C AND PUSH THEM LEFT ********** 130 K = K + 1 C 140 DO 170 J = K, L C DO 150 I = K, L IF (I .EQ. J) GO TO 150 IF (A(I,J) .NE. 0.0) GO TO 170 150 CONTINUE C M = K IEXC = 2 GO TO 20 170 CONTINUE C ********** NOW BALANCE THE SUBMATRIX IN ROWS K TO L ********** DO 180 I = K, L 180 SCALE(I) = 1.0 C ********** ITERATIVE LOOP FOR NORM REDUCTION ********** 190 NOCONV = .FALSE. C DO 270 I = K, L C = 0.0 R = 0.0 C DO 200 J = K, L IF (J .EQ. I) GO TO 200 C = C + ABS(A(J,I)) R = R + ABS(A(I,J)) 200 CONTINUE C ********** GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ********** IF (C .EQ. 0.0 .OR. R .EQ. 0.0) GO TO 270 G = R / RADIX F = 1.0 S = C + R 210 IF (C .GE. G) GO TO 220 F = F * RADIX C = C * B2 GO TO 210 220 G = R * RADIX 230 IF (C .LT. G) GO TO 240 F = F / RADIX C = C / B2 GO TO 230 C ********** NOW BALANCE ********** 240 IF ((C + R) / F .GE. 0.95 * S) GO TO 270 G = 1.0 / F SCALE(I) = SCALE(I) * F NOCONV = .TRUE. C DO 250 J = K, N 250 A(I,J) = A(I,J) * G C DO 260 J = 1, L 260 A(J,I) = A(J,I) * F C 270 CONTINUE C IF (NOCONV) GO TO 190 C 280 LOW = K IGH = L RETURN END SUBROUTINE BALINV (NZ,N,Z,LOW,IGH,SCALE) INTEGER I,J,K,N,II,NZ,IGH,LOW REAL Z(NZ,N),SCALE(N) REAL S C----------------------------------------------------------------------- C GIVEN A MATRIX A OF ORDER N. BALANC TRANSFORMS A INTO C THE MATRIX B BY THE SIMILARITY TRANSFORMATION C B = D**(-1)*TRANSPOSE(P)*A*P*D C WHERE D IS A DIAGONAL MATRIX AND P A PERMUTATION MATRIX. C THE INFORMATION CONCERNING D AND P IS STORED IN IGH, LOW, C AND SCALE. THE ORDER IN WHICH THE INTERCHANGES WERE MADE C IS N TO IGH + 1, AND THEN 1 TO LOW - 1. C C Z IS A MATRIX OF ORDER N. BALINV TRANSFORMS Z INTO THE C MATRIX W USING THE INVERSE SIMILARITY TRANSFORM C W = P*D*Z*D**(-1)*TRANSPOSE(P) C C ON INPUT- C C NZ IS THE ROW DIMENSION OF THE MATRIX Z IN THE CALLING C PROGRAM, C C N IS THE ORDER OF THE MATRIX, C C LOW AND IGH ARE INTEGERS DETERMINED BY BALANC, C C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS C AND SCALING FACTORS USED BY BALANC, C C ON OUTPUT- C C Z CONTAINS THE TRANSFORMED MATRIX W C C----------------------------------------------------------------------- C IF (IGH .EQ. LOW) GO TO 30 C DO 11 I = LOW, IGH S = SCALE(I) DO 10 J = 1, N 10 Z(I,J) = Z(I,J) * S 11 CONTINUE C DO 21 J = LOW, IGH S = 1.0/SCALE(J) DO 20 I = 1, N 20 Z(I,J) = Z(I,J) * S 21 CONTINUE C C ********- FOR I=LOW-1 STEP -1 UNTIL 1, C IGH+1 STEP 1 UNTIL N DO -- ********** C 30 DO 60 II = 1, N I = II IF (I .GE. LOW .AND. I .LE. IGH) GO TO 60 IF (I .LT. LOW) I = LOW - II K = SCALE(I) IF (K .EQ. I) GO TO 60 C DO 40 J = 1, N S = Z(I,J) Z(I,J) = Z(K,J) 40 Z(K,J) = S C DO 50 J = 1, N S = Z(J,I) Z(J,I) = Z(J,K) 50 Z(J,K) = S 60 CONTINUE RETURN END SUBROUTINE ELMHES(NM,N,LOW,IGH,A,INT) C INTEGER I,J,M,N,LA,NM,IGH,KP1,LOW,MM1,MP1 REAL A(NM,N) REAL X,Y C REAL ABS INTEGER INT(IGH) C----------------------------------------------------------------------- C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ELMHES, C NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). C C GIVEN A REAL GENERAL MATRIX, THIS SUBROUTINE C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY C STABILIZED ELEMENTARY SIMILARITY TRANSFORMATIONS. C C ON INPUT- C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C N IS THE ORDER OF THE MATRIX, C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, C SET LOW=1, IGH=N, C C A CONTAINS THE INPUT MATRIX. C C ON OUTPUT- C C A CONTAINS THE HESSENBERG MATRIX. THE MULTIPLIERS C WHICH WERE USED IN THE REDUCTION ARE STORED IN THE C REMAINING TRIANGLE UNDER THE HESSENBERG MATRIX, C C INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS C INTERCHANGED IN THE REDUCTION. C ONLY ELEMENTS LOW THROUGH IGH ARE USED. C C----------------------------------------------------------------------- C LA = IGH - 1 KP1 = LOW + 1 IF (LA .LT. KP1) GO TO 200 C DO 180 M = KP1, LA MM1 = M - 1 X = 0.0 I = M C DO 100 J = M, IGH IF (ABS(A(J,MM1)) .LE. ABS(X)) GO TO 100 X = A(J,MM1) I = J 100 CONTINUE C INT(M) = I IF (I .EQ. M) GO TO 130 C ********** INTERCHANGE ROWS AND COLUMNS OF A ********** DO 110 J = MM1, N Y = A(I,J) A(I,J) = A(M,J) A(M,J) = Y 110 CONTINUE C DO 120 J = 1, IGH Y = A(J,I) A(J,I) = A(J,M) A(J,M) = Y 120 CONTINUE C ********** END INTERCHANGE ********** 130 IF (X .EQ. 0.0) GO TO 180 MP1 = M + 1 C DO 160 I = MP1, IGH Y = A(I,MM1) IF (Y .EQ. 0.0) GO TO 160 Y = Y / X A(I,MM1) = Y C DO 140 J = M, N 140 A(I,J) = A(I,J) - Y * A(M,J) C DO 150 J = 1, IGH 150 A(J,M) = A(J,M) + Y * A(J,I) C 160 CONTINUE C 180 CONTINUE C 200 RETURN END SUBROUTINE ELMHS0(NM,N,LOW,IGH,A,INT) C INTEGER I,J,M,N,LA,NM,IGH,KP1,LOW,MM1,MP1 REAL A(NM,N) REAL X,Y C REAL ABS REAL INT(IGH) C----------------------------------------------------------------------- C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ELMHES, C NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). C C GIVEN A REAL GENERAL MATRIX, THIS SUBROUTINE C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY C STABILIZED ELEMENTARY SIMILARITY TRANSFORMATIONS. C C ON INPUT- C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C N IS THE ORDER OF THE MATRIX, C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, C SET LOW=1, IGH=N, C C A CONTAINS THE INPUT MATRIX. C C ON OUTPUT- C C A CONTAINS THE HESSENBERG MATRIX. THE MULTIPLIERS C WHICH WERE USED IN THE REDUCTION ARE STORED IN THE C REMAINING TRIANGLE UNDER THE HESSENBERG MATRIX, C C INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS C INTERCHANGED IN THE REDUCTION. C ONLY ELEMENTS LOW THROUGH IGH ARE USED. C C----------------------------------------------------------------------- C LA = IGH - 1 KP1 = LOW + 1 IF (LA .LT. KP1) GO TO 200 C DO 180 M = KP1, LA MM1 = M - 1 X = 0.0 I = M C DO 100 J = M, IGH IF (ABS(A(J,MM1)) .LE. ABS(X)) GO TO 100 X = A(J,MM1) I = J 100 CONTINUE C INT(M) = I IF (I .EQ. M) GO TO 130 C ********** INTERCHANGE ROWS AND COLUMNS OF A ********** DO 110 J = MM1, N Y = A(I,J) A(I,J) = A(M,J) A(M,J) = Y 110 CONTINUE C DO 120 J = 1, IGH Y = A(J,I) A(J,I) = A(J,M) A(J,M) = Y 120 CONTINUE C ********** END INTERCHANGE ********** 130 IF (X .EQ. 0.0) GO TO 180 MP1 = M + 1 C DO 160 I = MP1, IGH Y = A(I,MM1) IF (Y .EQ. 0.0) GO TO 160 Y = Y / X A(I,MM1) = Y C DO 140 J = M, N 140 A(I,J) = A(I,J) - Y * A(M,J) C DO 150 J = 1, IGH 150 A(J,M) = A(J,M) + Y * A(J,I) C 160 CONTINUE C 180 CONTINUE C 200 RETURN END SUBROUTINE ORTHES(NM,N,LOW,IGH,A,ORT) C INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW REAL A(NM,N),ORT(IGH) REAL F,G,H,SCALE C REAL SQRT,ABS C----------------------------------------------------------------------- C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ORTHES, C NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). C C GIVEN A REAL GENERAL MATRIX, THIS SUBROUTINE C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY C ORTHOGONAL SIMILARITY TRANSFORMATIONS. C C ON INPUT- C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C N IS THE ORDER OF THE MATRIX, C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, C SET LOW=1, IGH=N, C C A CONTAINS THE INPUT MATRIX. C C ON OUTPUT- C C A CONTAINS THE HESSENBERG MATRIX. INFORMATION ABOUT C THE ORTHOGONAL TRANSFORMATIONS USED IN THE REDUCTION C IS STORED IN THE REMAINING TRIANGLE UNDER THE C HESSENBERG MATRIX, C C ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS. C ONLY ELEMENTS LOW THROUGH IGH ARE USED. C C----------------------------------------------------------------------- C LA = IGH - 1 KP1 = LOW + 1 IF (LA .LT. KP1) GO TO 200 C DO 180 M = KP1, LA H = 0.0 ORT(M) = 0.0 SCALE = 0.0 C ********** SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ********** DO 90 I = M, IGH 90 SCALE = SCALE + ABS(A(I,M-1)) C IF (SCALE .EQ. 0.0) GO TO 180 MP = M + IGH C ********** FOR I=IGH STEP -1 UNTIL M DO -- ********** DO 100 II = M, IGH I = MP - II ORT(I) = A(I,M-1) / SCALE H = H + ORT(I) * ORT(I) 100 CONTINUE C G = SQRT(H) IF (ORT(M) .GE. 0.0) G = -G H = H - ORT(M) * G ORT(M) = ORT(M) - G C ********** FORM (I-(U*UT)/H) * A ********** DO 130 J = M, N F = 0.0 C ********** FOR I=IGH STEP -1 UNTIL M DO -- ********** DO 110 II = M, IGH I = MP - II F = F + ORT(I) * A(I,J) 110 CONTINUE C F = F / H C DO 120 I = M, IGH 120 A(I,J) = A(I,J) - F * ORT(I) C 130 CONTINUE C ********** FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ********** DO 160 I = 1, IGH F = 0.0 C ********** FOR J=IGH STEP -1 UNTIL M DO -- ********** DO 140 JJ = M, IGH J = MP - JJ F = F + ORT(J) * A(I,J) 140 CONTINUE C F = F / H C DO 150 J = M, IGH 150 A(I,J) = A(I,J) - F * ORT(J) C 160 CONTINUE C ORT(M) = SCALE * ORT(M) A(M,M-1) = SCALE * G 180 CONTINUE C 200 RETURN END SUBROUTINE HQR(NM,N,LOW,IGH,H,WR,WI,IERR) C INTEGER I,J,K,L,M,N,EN,LL,MM,NA,NM,IGH,ITS,LOW,MP2,ENM2,IERR REAL H(NM,N),WR(N),WI(N) REAL P,Q,R,S,T,W,X,Y,ZZ,NORM,MACHEP,SPMPAR C REAL SQRT,ABS C INTEGER MIN0 LOGICAL NOTLAS C----------------------------------------------------------------------- C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE HQR, C NUM. MATH. 14, 219-231(1970) BY MARTIN, PETERS, AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 359-371(1971). C C THIS SUBROUTINE FINDS THE EIGENVALUES OF A REAL C UPPER HESSENBERG MATRIX BY THE QR METHOD. C C ON INPUT- C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C N IS THE ORDER OF THE MATRIX, C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, C SET LOW=1, IGH=N, C C H CONTAINS THE UPPER HESSENBERG MATRIX. INFORMATION ABOUT C THE TRANSFORMATIONS USED IN THE REDUCTION TO HESSENBERG C FORM BY ELMHES OR ORTHES, IF PERFORMED, IS STORED C IN THE REMAINING TRIANGLE UNDER THE HESSENBERG MATRIX. C C ON OUTPUT- C C H HAS BEEN DESTROYED. THEREFORE, IT MUST BE SAVED C BEFORE CALLING HQR IF SUBSEQUENT CALCULATION AND C BACK TRANSFORMATION OF EIGENVECTORS IS TO BE PERFORMED, C C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE EIGENVALUES. THE EIGENVALUES C ARE UNORDERED EXCEPT THAT COMPLEX CONJUGATE PAIRS C OF VALUES APPEAR CONSECUTIVELY WITH THE EIGENVALUE C HAVING THE POSITIVE IMAGINARY PART FIRST. IF AN C ERROR EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT C FOR INDICES IERR+1,...,N, C C IERR IS SET TO C ZERO FOR NORMAL RETURN, C J IF THE J-TH EIGENVALUE HAS NOT BEEN C DETERMINED AFTER 30 ITERATIONS. C C----------------------------------------------------------------------- C C ********** MACHEP IS A MACHINE DEPENDENT PARAMETER. ASSIGN C MACHEP THE VALUE U WHERE U IS THE SMALLEST POSITIVE C FLOATING POINT NUMBER SUCH THAT 1.0 + U .GT. 1.0 . C MACHEP = SPMPAR(1) C C ********** C IERR = 0 NORM = 0.0 K = 1 C ********** STORE ROOTS ISOLATED BY BALANC C AND COMPUTE MATRIX NORM ********** DO 50 I = 1, N C DO 40 J = K, N 40 NORM = NORM + ABS(H(I,J)) C K = I IF (I .GE. LOW .AND. I .LE. IGH) GO TO 50 WR(I) = H(I,I) WI(I) = 0.0 50 CONTINUE C EN = IGH T = 0.0 C ********** SEARCH FOR NEXT EIGENVALUES ********** 60 IF (EN .LT. LOW) GO TO 1001 ITS = 0 NA = EN - 1 ENM2 = NA - 1 C ********** LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT C FOR L=EN STEP -1 UNTIL LOW DO -- ********** 70 DO 80 LL = LOW, EN L = EN + LOW - LL IF (L .EQ. LOW) GO TO 100 S = ABS(H(L-1,L-1)) + ABS(H(L,L)) IF (S .EQ. 0.0) S = NORM IF (ABS(H(L,L-1)) .LE. MACHEP * S) GO TO 100 80 CONTINUE C ********** FORM SHIFT ********** 100 X = H(EN,EN) IF (L .EQ. EN) GO TO 270 Y = H(NA,NA) W = H(EN,NA) * H(NA,EN) IF (L .EQ. NA) GO TO 280 IF (ITS .EQ. 30) GO TO 1000 IF (ITS .NE. 10 .AND. ITS .NE. 20) GO TO 130 C ********** FORM EXCEPTIONAL SHIFT ********** T = T + X C DO 120 I = LOW, EN 120 H(I,I) = H(I,I) - X C S = ABS(H(EN,NA)) + ABS(H(NA,ENM2)) X = 0.75 * S Y = X W = -0.4375 * S * S 130 ITS = ITS + 1 C ********** LOOK FOR TWO CONSECUTIVE SMALL C SUB-DIAGONAL ELEMENTS. C FOR M=EN-2 STEP -1 UNTIL L DO -- ********** DO 140 MM = L, ENM2 M = ENM2 + L - MM ZZ = H(M,M) R = X - ZZ S = Y - ZZ P = (R * S - W) / H(M+1,M) + H(M,M+1) Q = H(M+1,M+1) - ZZ - R - S R = H(M+2,M+1) S = ABS(P) + ABS(Q) + ABS(R) P = P / S Q = Q / S R = R / S IF (M .EQ. L) GO TO 150 IF (ABS(H(M,M-1)) * (ABS(Q) + ABS(R)) .LE. MACHEP * ABS(P) X * (ABS(H(M-1,M-1)) + ABS(ZZ) + ABS(H(M+1,M+1)))) GO TO 150 140 CONTINUE C 150 MP2 = M + 2 C DO 160 I = MP2, EN H(I,I-2) = 0.0 IF (I .EQ. MP2) GO TO 160 H(I,I-3) = 0.0 160 CONTINUE C ********** DOUBLE QR STEP INVOLVING ROWS L TO EN AND C COLUMNS M TO EN ********** DO 260 K = M, NA NOTLAS = K .NE. NA IF (K .EQ. M) GO TO 170 P = H(K,K-1) Q = H(K+1,K-1) R = 0.0 IF (NOTLAS) R = H(K+2,K-1) X = ABS(P) + ABS(Q) + ABS(R) IF (X .EQ. 0.0) GO TO 260 P = P / X Q = Q / X R = R / X 170 S = SQRT(P*P + Q*Q + R*R) IF (P .LT. 0.0) S = -S IF (K .EQ. M) GO TO 180 H(K,K-1) = -S * X GO TO 190 180 IF (L .NE. M) H(K,K-1) = -H(K,K-1) 190 P = P + S X = P / S Y = Q / S ZZ = R / S Q = Q / P R = R / P C ********** ROW MODIFICATION ********** DO 210 J = K, EN P = H(K,J) + Q * H(K+1,J) IF (.NOT. NOTLAS) GO TO 200 P = P + R * H(K+2,J) H(K+2,J) = H(K+2,J) - P * ZZ 200 H(K+1,J) = H(K+1,J) - P * Y H(K,J) = H(K,J) - P * X 210 CONTINUE C J = MIN0(EN,K+3) C ********** COLUMN MODIFICATION ********** DO 230 I = L, J P = X * H(I,K) + Y * H(I,K+1) IF (.NOT. NOTLAS) GO TO 220 P = P + ZZ * H(I,K+2) H(I,K+2) = H(I,K+2) - P * R 220 H(I,K+1) = H(I,K+1) - P * Q H(I,K) = H(I,K) - P 230 CONTINUE C 260 CONTINUE C GO TO 70 C ********** ONE ROOT FOUND ********** 270 WR(EN) = X + T WI(EN) = 0.0 EN = NA GO TO 60 C ********** TWO ROOTS FOUND ********** 280 P = (Y - X) / 2.0 Q = P * P + W ZZ = SQRT(ABS(Q)) X = X + T IF (Q .LT. 0.0) GO TO 320 C ********** REAL PAIR ********** IF (P .LT. 0.0) ZZ = -ZZ ZZ = P + ZZ WR(NA) = X + ZZ WR(EN) = WR(NA) IF (ZZ .NE. 0.0) WR(EN) = X - W / ZZ WI(NA) = 0.0 WI(EN) = 0.0 GO TO 330 C ********** COMPLEX PAIR ********** 320 WR(NA) = X + P WR(EN) = X + P WI(NA) = ZZ WI(EN) = -ZZ 330 EN = ENM2 GO TO 60 C ********** SET ERROR -- NO CONVERGENCE TO AN C EIGENVALUE AFTER 30 ITERATIONS ********** 1000 IERR = EN 1001 RETURN END SUBROUTINE BALBAK(NM,N,LOW,IGH,SCALE,M,Z) C INTEGER I,J,K,M,N,II,NM,IGH,LOW REAL SCALE(N),Z(NM,M) REAL S C----------------------------------------------------------------------- C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BALBAK, C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). C C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL GENERAL C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING C BALANCED MATRIX DETERMINED BY BALANC. C C ON INPUT- C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C N IS THE ORDER OF THE MATRIX, C C LOW AND IGH ARE INTEGERS DETERMINED BY BALANC, C C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS C AND SCALING FACTORS USED BY BALANC, C C M IS THE NUMBER OF COLUMNS OF Z TO BE BACK TRANSFORMED, C C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGEN- C VECTORS TO BE BACK TRANSFORMED IN ITS FIRST M COLUMNS. C C ON OUTPUT- C C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE C TRANSFORMED EIGENVECTORS IN ITS FIRST M COLUMNS. C C----------------------------------------------------------------------- C IF (M .EQ. 0) GO TO 200 IF (IGH .EQ. LOW) GO TO 120 C DO 110 I = LOW, IGH S = SCALE(I) C ********** LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED C IF THE FOREGOING STATEMENT IS REPLACED BY C S=1.0/SCALE(I). ********** DO 100 J = 1, M 100 Z(I,J) = Z(I,J) * S C 110 CONTINUE C ********- FOR I=LOW-1 STEP -1 UNTIL 1, C IGH+1 STEP 1 UNTIL N DO -- ********** 120 DO 140 II = 1, N I = II IF (I .GE. LOW .AND. I .LE. IGH) GO TO 140 IF (I .LT. LOW) I = LOW - II K = SCALE(I) IF (K .EQ. I) GO TO 140 C DO 130 J = 1, M S = Z(I,J) Z(I,J) = Z(K,J) Z(K,J) = S 130 CONTINUE C 140 CONTINUE C 200 RETURN END SUBROUTINE ELTRAN(NM,N,LOW,IGH,A,INT,Z) C INTEGER I,J,N,KL,MM,MP,NM,IGH,LOW,MP1 REAL A(NM,IGH),Z(NM,N) INTEGER INT(IGH) C----------------------------------------------------------------------- C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ELMTRANS, C NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). C C THIS SUBROUTINE ACCUMULATES THE STABILIZED ELEMENTARY C SIMILARITY TRANSFORMATIONS USED IN THE REDUCTION OF A C REAL GENERAL MATRIX TO UPPER HESSENBERG FORM BY ELMHES. C C ON INPUT- C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C N IS THE ORDER OF THE MATRIX, C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, C SET LOW=1, IGH=N, C C A CONTAINS THE MULTIPLIERS WHICH WERE USED IN THE C REDUCTION BY ELMHES IN ITS LOWER TRIANGLE C BELOW THE SUBDIAGONAL, C C INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS C INTERCHANGED IN THE REDUCTION BY ELMHES. C ONLY ELEMENTS LOW THROUGH IGH ARE USED. C C ON OUTPUT- C C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE C REDUCTION BY ELMHES. C C----------------------------------------------------------------------- C C ********** INITIALIZE Z TO IDENTITY MATRIX ********** DO 80 I = 1, N C DO 60 J = 1, N 60 Z(I,J) = 0.0 C Z(I,I) = 1.0 80 CONTINUE C KL = IGH - LOW - 1 IF (KL .LT. 1) GO TO 200 C ********** FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- ********** DO 140 MM = 1, KL MP = IGH - MM MP1 = MP + 1 C DO 100 I = MP1, IGH 100 Z(I,MP) = A(I,MP-1) C I = INT(MP) IF (I .EQ. MP) GO TO 140 C DO 130 J = MP, IGH Z(MP,J) = Z(I,J) Z(I,J) = 0.0 130 CONTINUE C Z(I,MP) = 1.0 140 CONTINUE C 200 RETURN END SUBROUTINE ELTRN0(NM,N,LOW,IGH,A,INT,Z) C INTEGER I,J,N,KL,MM,MP,NM,IGH,LOW,MP1 REAL A(NM,IGH),Z(NM,N) REAL INT(IGH) C----------------------------------------------------------------------- C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ELMTRANS, C NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). C C THIS SUBROUTINE ACCUMULATES THE STABILIZED ELEMENTARY C SIMILARITY TRANSFORMATIONS USED IN THE REDUCTION OF A C REAL GENERAL MATRIX TO UPPER HESSENBERG FORM BY ELMHS0. C C ON INPUT- C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C N IS THE ORDER OF THE MATRIX, C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, C SET LOW=1, IGH=N, C C A CONTAINS THE MULTIPLIERS WHICH WERE USED IN THE C REDUCTION BY ELMHS0 IN ITS LOWER TRIANGLE C BELOW THE SUBDIAGONAL, C C INT CONTAINS INFORMATION ON THE ROWS AND COLUMNS C INTERCHANGED IN THE REDUCTION BY ELMHS0. C ONLY ELEMENTS LOW THROUGH IGH ARE USED. C C ON OUTPUT- C C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE C REDUCTION BY ELMHS0. C C----------------------------------------------------------------------- C C ********** INITIALIZE Z TO IDENTITY MATRIX ********** DO 80 I = 1, N C DO 60 J = 1, N 60 Z(I,J) = 0.0 C Z(I,I) = 1.0 80 CONTINUE C KL = IGH - LOW - 1 IF (KL .LT. 1) GO TO 200 C ********** FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- ********** DO 140 MM = 1, KL MP = IGH - MM MP1 = MP + 1 C DO 100 I = MP1, IGH 100 Z(I,MP) = A(I,MP-1) C I = INT(MP) IF (I .EQ. MP) GO TO 140 C DO 130 J = MP, IGH Z(MP,J) = Z(I,J) Z(I,J) = 0.0 130 CONTINUE C Z(I,MP) = 1.0 140 CONTINUE C 200 RETURN END SUBROUTINE ORTRAN(NM,N,LOW,IGH,A,ORT,Z) C INTEGER I,J,N,KL,MM,MP,NM,IGH,LOW,MP1 REAL A(NM,IGH),ORT(IGH),Z(NM,N) REAL G C----------------------------------------------------------------------- C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ORTRANS, C NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). C C THIS SUBROUTINE ACCUMULATES THE ORTHOGONAL SIMILARITY C TRANSFORMATIONS USED IN THE REDUCTION OF A REAL GENERAL C MATRIX TO UPPER HESSENBERG FORM BY ORTHES. C C ON INPUT- C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C N IS THE ORDER OF THE MATRIX, C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, C SET LOW=1, IGH=N, C C A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS- C FORMATIONS USED IN THE REDUCTION BY ORTHES C IN ITS STRICT LOWER TRIANGLE, C C ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANS- C FORMATIONS USED IN THE REDUCTION BY ORTHES. C ONLY ELEMENTS LOW THROUGH IGH ARE USED. C C ON OUTPUT- C C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE C REDUCTION BY ORTHES, C C ORT HAS BEEN ALTERED. C C----------------------------------------------------------------------- C C ********** INITIALIZE Z TO IDENTITY MATRIX ********** DO 80 I = 1, N C DO 60 J = 1, N 60 Z(I,J) = 0.0 C Z(I,I) = 1.0 80 CONTINUE C KL = IGH - LOW - 1 IF (KL .LT. 1) GO TO 200 C ********** FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- ********** DO 140 MM = 1, KL MP = IGH - MM IF (A(MP,MP-1) .EQ. 0.0) GO TO 140 MP1 = MP + 1 C DO 100 I = MP1, IGH 100 ORT(I) = A(I,MP-1) C DO 130 J = MP, IGH G = 0.0 C DO 110 I = MP, IGH 110 G = G + ORT(I) * Z(I,J) C ********** DIVISOR BELOW IS NEGATIVE OF H FORMED IN ORTHES. C DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ********** G = (G / ORT(MP)) / A(MP,MP-1) C DO 120 I = MP, IGH 120 Z(I,J) = Z(I,J) + G * ORT(I) C 130 CONTINUE C 140 CONTINUE C 200 RETURN END SUBROUTINE ORTRN1(N,LOW,IGH,A,NA,Z,NZ,ORT) C INTEGER I,J,N,KL,MM,MP,NA,IGH,LOW,MP1,NZ REAL A(NA,IGH),ORT(IGH),Z(NZ,N) REAL G C----------------------------------------------------------------------- C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ORTRANS, C NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). C C THIS SUBROUTINE ACCUMULATES THE ORTHOGONAL SIMILARITY C TRANSFORMATIONS USED IN THE REDUCTION OF A REAL GENERAL C MATRIX TO UPPER HESSENBERG FORM BY ORTHES. C C ON INPUT- C C N IS THE ORDER OF THE MATRIX, C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, C SET LOW=1, IGH=N, C C A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS- C FORMATIONS USED IN THE REDUCTION BY ORTHES C IN ITS STRICT LOWER TRIANGLE, C C NA MUST BE SET TO THE ROW DIMENSION OF THE 2-DIMENSIONAL C ARRAY PARAMETER A AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C NZ MUST BE SET TO THE ROW DIMENSION OF THE 2-DIMENSIONAL C ARRAY PARAMETER Z AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANS- C FORMATIONS USED IN THE REDUCTION BY ORTHES. C ONLY ELEMENTS LOW THROUGH IGH ARE USED. C C ON OUTPUT- C C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE C REDUCTION BY ORTHES, C C ORT HAS BEEN ALTERED. C C----------------------------------------------------------------------- C C ********** INITIALIZE Z TO IDENTITY MATRIX ********** DO 80 I = 1, N C DO 60 J = 1, N 60 Z(I,J) = 0.0 C Z(I,I) = 1.0 80 CONTINUE C KL = IGH - LOW - 1 IF (KL .LT. 1) GO TO 200 C ********** FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- ********** DO 140 MM = 1, KL MP = IGH - MM IF (A(MP,MP-1) .EQ. 0.0) GO TO 140 MP1 = MP + 1 C DO 100 I = MP1, IGH 100 ORT(I) = A(I,MP-1) C DO 130 J = MP, IGH G = 0.0 C DO 110 I = MP, IGH 110 G = G + ORT(I) * Z(I,J) C ********** DIVISOR BELOW IS NEGATIVE OF H FORMED IN ORTHES. C DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ********** G = (G / ORT(MP)) / A(MP,MP-1) C DO 120 I = MP, IGH 120 Z(I,J) = Z(I,J) + G * ORT(I) C 130 CONTINUE C 140 CONTINUE C 200 RETURN END SUBROUTINE HQR2(NM,N,LOW,IGH,H,WR,WI,Z,IERR) C INTEGER I,J,K,L,M,N,EN,II,JJ,LL,MM,NA,NM,NN, X IGH,ITS,LOW,MP2,ENM2,IERR REAL H(NM,N),WR(N),WI(N),Z(NM,N) REAL P,Q,R,S,T,W,X,Y,RA,SA,VI,VR,ZZ,NORM,MACHEP,SPMPAR C REAL SQRT,ABS C INTEGER MIN0 LOGICAL NOTLAS COMPLEX Z3 C COMPLEX CMPLX C REAL REAL,AIMAG C----------------------------------------------------------------------- C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE HQR2, C NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). C C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS C OF A REAL UPPER HESSENBERG MATRIX BY THE QR METHOD. THE C EIGENVECTORS OF A REAL GENERAL MATRIX CAN ALSO BE FOUND C IF ELMHES AND ELTRAN OR ORTHES AND ORTRAN HAVE C BEEN USED TO REDUCE THIS GENERAL MATRIX TO HESSENBERG FORM C AND TO ACCUMULATE THE SIMILARITY TRANSFORMATIONS. C C ON INPUT- C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C N IS THE ORDER OF THE MATRIX, C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE BALANC. IF BALANC HAS NOT BEEN USED, C SET LOW=1, IGH=N, C C H CONTAINS THE UPPER HESSENBERG MATRIX, C C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED BY ELTRAN C AFTER THE REDUCTION BY ELMHES, OR BY ORTRAN AFTER THE C REDUCTION BY ORTHES, IF PERFORMED. IF THE EIGENVECTORS C OF THE HESSENBERG MATRIX ARE DESIRED, Z MUST CONTAIN THE C IDENTITY MATRIX. C C ON OUTPUT- C C H HAS BEEN DESTROYED, C C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE EIGENVALUES. THE EIGENVALUES C ARE UNORDERED EXCEPT THAT COMPLEX CONJUGATE PAIRS C OF VALUES APPEAR CONSECUTIVELY WITH THE EIGENVALUE C HAVING THE POSITIVE IMAGINARY PART FIRST. IF AN C ERROR EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT C FOR INDICES IERR+1,...,N, C C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS. C IF THE I-TH EIGENVALUE IS REAL, THE I-TH COLUMN OF Z C CONTAINS ITS EIGENVECTOR. IF THE I-TH EIGENVALUE IS COMPLEX C WITH POSITIVE IMAGINARY PART, THE I-TH AND (I+1)-TH C COLUMNS OF Z CONTAIN THE REAL AND IMAGINARY PARTS OF ITS C EIGENVECTOR. THE EIGENVECTORS ARE UNNORMALIZED. IF AN C ERROR EXIT IS MADE, NONE OF THE EIGENVECTORS HAS BEEN FOUND, C C IERR IS SET TO C ZERO FOR NORMAL RETURN, C J IF THE J-TH EIGENVALUE HAS NOT BEEN C DETERMINED AFTER 30 ITERATIONS. C C ARITHMETIC IS REAL EXCEPT FOR THE REPLACEMENT OF THE ALGOL C PROCEDURE CDIV BY COMPLEX DIVISION. C C----------------------------------------------------------------------- C C ********** MACHEP IS A MACHINE DEPENDENT PARAMETER. ASSIGN C MACHEP THE VALUE U WHERE U IS THE SMALLEST POSITIVE C FLOATING POINT NUMBER SUCH THAT 1.0 + U .GT. 1.0 . C MACHEP = SPMPAR(1) C C ********** C IERR = 0 NORM = 0.0 K = 1 C ********** STORE ROOTS ISOLATED BY BALANC C AND COMPUTE MATRIX NORM ********** DO 50 I = 1, N C DO 40 J = K, N 40 NORM = NORM + ABS(H(I,J)) C K = I IF (I .GE. LOW .AND. I .LE. IGH) GO TO 50 WR(I) = H(I,I) WI(I) = 0.0 50 CONTINUE C EN = IGH T = 0.0 C ********** SEARCH FOR NEXT EIGENVALUES ********** 60 IF (EN .LT. LOW) GO TO 340 ITS = 0 NA = EN - 1 ENM2 = NA - 1 C ********** LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT C FOR L=EN STEP -1 UNTIL LOW DO -- ********** 70 DO 80 LL = LOW, EN L = EN + LOW - LL IF (L .EQ. LOW) GO TO 100 S = ABS(H(L-1,L-1)) + ABS(H(L,L)) IF (S .EQ. 0.0) S = NORM IF (ABS(H(L,L-1)) .LE. MACHEP * S) GO TO 100 80 CONTINUE C ********** FORM SHIFT ********** 100 X = H(EN,EN) IF (L .EQ. EN) GO TO 270 Y = H(NA,NA) W = H(EN,NA) * H(NA,EN) IF (L .EQ. NA) GO TO 280 IF (ITS .EQ. 30) GO TO 1000 IF (ITS .NE. 10 .AND. ITS .NE. 20) GO TO 130 C ********** FORM EXCEPTIONAL SHIFT ********** T = T + X C DO 120 I = LOW, EN 120 H(I,I) = H(I,I) - X C S = ABS(H(EN,NA)) + ABS(H(NA,ENM2)) X = 0.75 * S Y = X W = -0.4375 * S * S 130 ITS = ITS + 1 C ********** LOOK FOR TWO CONSECUTIVE SMALL C SUB-DIAGONAL ELEMENTS. C FOR M=EN-2 STEP -1 UNTIL L DO -- ********** DO 140 MM = L, ENM2 M = ENM2 + L - MM ZZ = H(M,M) R = X - ZZ S = Y - ZZ P = (R * S - W) / H(M+1,M) + H(M,M+1) Q = H(M+1,M+1) - ZZ - R - S R = H(M+2,M+1) S = ABS(P) + ABS(Q) + ABS(R) P = P / S Q = Q / S R = R / S IF (M .EQ. L) GO TO 150 IF (ABS(H(M,M-1)) * (ABS(Q) + ABS(R)) .LE. MACHEP * ABS(P) X * (ABS(H(M-1,M-1)) + ABS(ZZ) + ABS(H(M+1,M+1)))) GO TO 150 140 CONTINUE C 150 MP2 = M + 2 C DO 160 I = MP2, EN H(I,I-2) = 0.0 IF (I .EQ. MP2) GO TO 160 H(I,I-3) = 0.0 160 CONTINUE C ********** DOUBLE QR STEP INVOLVING ROWS L TO EN AND C COLUMNS M TO EN ********** DO 260 K = M, NA NOTLAS = K .NE. NA IF (K .EQ. M) GO TO 170 P = H(K,K-1) Q = H(K+1,K-1) R = 0.0 IF (NOTLAS) R = H(K+2,K-1) X = ABS(P) + ABS(Q) + ABS(R) IF (X .EQ. 0.0) GO TO 260 P = P / X Q = Q / X R = R / X 170 S = SQRT(P*P + Q*Q + R*R) IF (P .LT. 0.0) S = -S IF (K .EQ. M) GO TO 180 H(K,K-1) = -S * X GO TO 190 180 IF (L .NE. M) H(K,K-1) = -H(K,K-1) 190 P = P + S X = P / S Y = Q / S ZZ = R / S Q = Q / P R = R / P C ********** ROW MODIFICATION ********** DO 210 J = K, N P = H(K,J) + Q * H(K+1,J) IF (.NOT. NOTLAS) GO TO 200 P = P + R * H(K+2,J) H(K+2,J) = H(K+2,J) - P * ZZ 200 H(K+1,J) = H(K+1,J) - P * Y H(K,J) = H(K,J) - P * X 210 CONTINUE C J = MIN0(EN,K+3) C ********** COLUMN MODIFICATION ********** DO 230 I = 1, J P = X * H(I,K) + Y * H(I,K+1) IF (.NOT. NOTLAS) GO TO 220 P = P + ZZ * H(I,K+2) H(I,K+2) = H(I,K+2) - P * R 220 H(I,K+1) = H(I,K+1) - P * Q H(I,K) = H(I,K) - P 230 CONTINUE C ********** ACCUMULATE TRANSFORMATIONS ********** DO 250 I = LOW, IGH P = X * Z(I,K) + Y * Z(I,K+1) IF (.NOT. NOTLAS) GO TO 240 P = P + ZZ * Z(I,K+2) Z(I,K+2) = Z(I,K+2) - P * R 240 Z(I,K+1) = Z(I,K+1) - P * Q Z(I,K) = Z(I,K) - P 250 CONTINUE C 260 CONTINUE C GO TO 70 C ********** ONE ROOT FOUND ********** 270 H(EN,EN) = X + T WR(EN) = H(EN,EN) WI(EN) = 0.0 EN = NA GO TO 60 C ********** TWO ROOTS FOUND ********** 280 P = (Y - X) / 2.0 Q = P * P + W ZZ = SQRT(ABS(Q)) H(EN,EN) = X + T X = H(EN,EN) H(NA,NA) = Y + T IF (Q .LT. 0.0) GO TO 320 C ********** REAL PAIR ********** IF (P .LT. 0.0) ZZ = -ZZ ZZ = P + ZZ WR(NA) = X + ZZ WR(EN) = WR(NA) IF (ZZ .NE. 0.0) WR(EN) = X - W / ZZ WI(NA) = 0.0 WI(EN) = 0.0 X = H(EN,NA) S = ABS(X) + ABS(ZZ) P = X / S Q = ZZ / S R = SQRT(P*P+Q*Q) P = P / R Q = Q / R C ********** ROW MODIFICATION ********** DO 290 J = NA, N ZZ = H(NA,J) H(NA,J) = Q * ZZ + P * H(EN,J) H(EN,J) = Q * H(EN,J) - P * ZZ 290 CONTINUE C ********** COLUMN MODIFICATION ********** DO 300 I = 1, EN ZZ = H(I,NA) H(I,NA) = Q * ZZ + P * H(I,EN) H(I,EN) = Q * H(I,EN) - P * ZZ 300 CONTINUE C ********** ACCUMULATE TRANSFORMATIONS ********** DO 310 I = LOW, IGH ZZ = Z(I,NA) Z(I,NA) = Q * ZZ + P * Z(I,EN) Z(I,EN) = Q * Z(I,EN) - P * ZZ 310 CONTINUE C GO TO 330 C ********** COMPLEX PAIR ********** 320 WR(NA) = X + P WR(EN) = X + P WI(NA) = ZZ WI(EN) = -ZZ 330 EN = ENM2 GO TO 60 C ********** ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND C VECTORS OF UPPER TRIANGULAR FORM ********** 340 IF (NORM .EQ. 0.0) GO TO 1001 C ********** FOR EN=N STEP -1 UNTIL 1 DO -- ********** DO 800 NN = 1, N EN = N + 1 - NN P = WR(EN) Q = WI(EN) NA = EN - 1 IF (Q) 710, 600, 800 C ********** REAL VECTOR ********** 600 M = EN H(EN,EN) = 1.0 IF (NA .EQ. 0) GO TO 800 C ********** FOR I=EN-1 STEP -1 UNTIL 1 DO -- ********** DO 700 II = 1, NA I = EN - II W = H(I,I) - P R = H(I,EN) IF (M .GT. NA) GO TO 620 C DO 610 J = M, NA 610 R = R + H(I,J) * H(J,EN) C 620 IF (WI(I) .GE. 0.0) GO TO 630 ZZ = W S = R GO TO 700 630 M = I IF (WI(I) .NE. 0.0) GO TO 640 T = W IF (W .EQ. 0.0) T = MACHEP * NORM H(I,EN) = -R / T GO TO 700 C ********** SOLVE REAL EQUATIONS ********** 640 X = H(I,I+1) Y = H(I+1,I) Q = (WR(I) - P) * (WR(I) - P) + WI(I) * WI(I) T = (X * S - ZZ * R) / Q H(I,EN) = T IF (ABS(X) .LE. ABS(ZZ)) GO TO 650 H(I+1,EN) = (-R - W * T) / X GO TO 700 650 H(I+1,EN) = (-S - Y * T) / ZZ 700 CONTINUE C ********** END REAL VECTOR ********** GO TO 800 C ********** COMPLEX VECTOR ********** 710 M = NA C ********** LAST VECTOR COMPONENT CHOSEN IMAGINARY SO THAT C EIGENVECTOR MATRIX IS TRIANGULAR ********** IF (ABS(H(EN,NA)) .LE. ABS(H(NA,EN))) GO TO 720 H(NA,NA) = Q / H(EN,NA) H(NA,EN) = -(H(EN,EN) - P) / H(EN,NA) GO TO 730 720 Z3 = CMPLX(0.0,-H(NA,EN)) / CMPLX(H(NA,NA)-P,Q) H(NA,NA) = REAL(Z3) H(NA,EN) = AIMAG(Z3) 730 H(EN,NA) = 0.0 H(EN,EN) = 1.0 ENM2 = NA - 1 IF (ENM2 .EQ. 0) GO TO 800 C ********** FOR I=EN-2 STEP -1 UNTIL 1 DO -- ********** DO 790 II = 1, ENM2 I = NA - II W = H(I,I) - P RA = 0.0 SA = H(I,EN) C DO 760 J = M, NA RA = RA + H(I,J) * H(J,NA) SA = SA + H(I,J) * H(J,EN) 760 CONTINUE C IF (WI(I) .GE. 0.0) GO TO 770 ZZ = W R = RA S = SA GO TO 790 770 M = I IF (WI(I) .NE. 0.0) GO TO 780 Z3 = CMPLX(-RA,-SA) / CMPLX(W,Q) H(I,NA) = REAL(Z3) H(I,EN) = AIMAG(Z3) GO TO 790 C ********** SOLVE COMPLEX EQUATIONS ********** 780 X = H(I,I+1) Y = H(I+1,I) VR = (WR(I) - P) * (WR(I) - P) + WI(I) * WI(I) - Q * Q VI = (WR(I) - P) * 2.0 * Q IF (VR .EQ. 0.0 .AND. VI .EQ. 0.0) VR = MACHEP * NORM X * (ABS(W) + ABS(Q) + ABS(X) + ABS(Y) + ABS(ZZ)) Z3 = CMPLX(X*R-ZZ*RA+Q*SA,X*S-ZZ*SA-Q*RA) / CMPLX(VR,VI) H(I,NA) = REAL(Z3) H(I,EN) = AIMAG(Z3) IF (ABS(X) .LE. ABS(ZZ) + ABS(Q)) GO TO 785 H(I+1,NA) = (-RA - W * H(I,NA) + Q * H(I,EN)) / X H(I+1,EN) = (-SA - W * H(I,EN) - Q * H(I,NA)) / X GO TO 790 785 Z3 = CMPLX(-R-Y*H(I,NA),-S-Y*H(I,EN)) / CMPLX(ZZ,Q) H(I+1,NA) = REAL(Z3) H(I+1,EN) = AIMAG(Z3) 790 CONTINUE C ********** END COMPLEX VECTOR ********** 800 CONTINUE C ********** END BACK SUBSTITUTION. C VECTORS OF ISOLATED ROOTS ********** DO 840 I = 1, N IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840 C DO 820 J = I, N 820 Z(I,J) = H(I,J) C 840 CONTINUE C ********** MULTIPLY BY TRANSFORMATION MATRIX TO GIVE C VECTORS OF ORIGINAL FULL MATRIX. C FOR J=N STEP -1 UNTIL LOW DO -- ********** DO 880 JJ = LOW, N J = N + LOW - JJ M = MIN0(J,IGH) C DO 880 I = LOW, IGH ZZ = 0.0 C DO 860 K = LOW, M 860 ZZ = ZZ + Z(I,K) * H(K,J) C Z(I,J) = ZZ 880 CONTINUE C GO TO 1001 C ********** SET ERROR -- NO CONVERGENCE TO AN C EIGENVALUE AFTER 30 ITERATIONS ********** 1000 IERR = EN 1001 RETURN END SUBROUTINE DEIG (IBAL,A,KA,N,WR,WI,IERR) C----------------------------------------------------------------------- C EIGENVALUES OF DOUBLE PRECISION MATRICES C----------------------------------------------------------------------- DOUBLE PRECISION A(KA,N), WR(N), WI(N) C LOW = 1 IGH = N IF (IBAL .NE. 0) CALL DBAL (KA,N,A,LOW,IGH,WR) CALL DORTH (KA,N,LOW,IGH,A,WR) CALL DHQR (KA,N,LOW,IGH,A,WR,WI,IERR) RETURN END SUBROUTINE DEIGV (IBAL,A,KA,N,WR,WI,ZR,ZI,IERR) C----------------------------------------------------------------------- C EIGENVALUES AND EIGENVECTORS OF DOUBLE PRECISION MATRICES C----------------------------------------------------------------------- DOUBLE PRECISION A(KA,N),WR(N),WI(N),ZR(KA,N),ZI(KA,N) C LOW = 1 IGH = N IF (IBAL .NE. 0) CALL DBAL (KA,N,A,LOW,IGH,ZI) CALL DORTH (KA,N,LOW,IGH,A,WR) CALL DORTRN (KA,N,LOW,IGH,A,WR,ZR) CALL DHQR2 (KA,N,LOW,IGH,A,WR,WI,ZR,IERR) IF (IERR .NE. 0) RETURN IF (IBAL .NE. 0) CALL DBABK (KA,N,LOW,IGH,ZI,N,ZR) C DO 30 K = 1,N IF (WI(K)) 30,10,20 10 DO 11 J = 1,N 11 ZI(J,K) = 0.D0 GO TO 30 20 KP1 = K + 1 DO 21 J = 1,N ZI(J,K) = ZR(J,KP1) ZR(J,KP1) = ZR(J,K) 21 ZI(J,KP1) = -ZI(J,K) 30 CONTINUE RETURN END SUBROUTINE DBAL(NM,N,A,LOW,IGH,SCALE) C INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC DOUBLE PRECISION A(NM,N),SCALE(N) DOUBLE PRECISION C,F,G,R,S,B2,RADIX INTEGER IPMPAR C DOUBLE PRECISION DABS LOGICAL NOCONV C----------------------------------------------------------------------- C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BALANCE, C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). C C DBAL BALANCES A DOUBLE PRECISION REAL MATRIX AND ISOLATES C EIGENVALUES WHENEVER POSSIBLE. C C ON INPUT- C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C N IS THE ORDER OF THE MATRIX, C C A CONTAINS THE INPUT MATRIX TO BE BALANCED. C C ON OUTPUT- C C A CONTAINS THE BALANCED MATRIX, C C LOW AND IGH ARE TWO INTEGERS SUCH THAT A(I,J) C IS EQUAL TO ZERO IF C (1) I IS GREATER THAN J AND C (2) J=1,...,LOW-1 OR I=IGH+1,...,N, C C SCALE CONTAINS INFORMATION DETERMINING THE C PERMUTATIONS AND SCALING FACTORS USED. C C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN C SCALE(J) = P(J), FOR J = 1,...,LOW-1 C = D(J,J), J = LOW,...,IGH C = P(J) J = IGH+1,...,N. C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1, C THEN 1 TO LOW-1. C C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY. C C THE ALGOL PROCEDURE EXC CONTAINED IN BALANCE APPEARS IN C DBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS C K,L HAVE BEEN REVERSED.) C C----------------------------------------------------------------------- C C ********** RADIX IS A MACHINE DEPENDENT PARAMETER SPECIFYING C THE BASE OF THE MACHINE FLOATING POINT REPRESENTATION. C RADIX = IPMPAR(4) C C ********** C B2 = RADIX * RADIX K = 1 L = N GO TO 100 C ********** IN-LINE PROCEDURE FOR ROW AND C COLUMN EXCHANGE ********** 20 SCALE(M) = J IF (J .EQ. M) GO TO 50 C DO 30 I = 1, L F = A(I,J) A(I,J) = A(I,M) A(I,M) = F 30 CONTINUE C DO 40 I = K, N F = A(J,I) A(J,I) = A(M,I) A(M,I) = F 40 CONTINUE C 50 GO TO (80,130), IEXC C ********** SEARCH FOR ROWS ISOLATING AN EIGENVALUE C AND PUSH THEM DOWN ********** 80 IF (L .EQ. 1) GO TO 280 L = L - 1 C ********** FOR J=L STEP -1 UNTIL 1 DO -- ********** 100 DO 120 JJ = 1, L J = L + 1 - JJ C DO 110 I = 1, L IF (I .EQ. J) GO TO 110 IF (A(J,I) .NE. 0.D0) GO TO 120 110 CONTINUE C M = L IEXC = 1 GO TO 20 120 CONTINUE C GO TO 140 C ********** SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE C AND PUSH THEM LEFT ********** 130 K = K + 1 C 140 DO 170 J = K, L C DO 150 I = K, L IF (I .EQ. J) GO TO 150 IF (A(I,J) .NE. 0.D0) GO TO 170 150 CONTINUE C M = K IEXC = 2 GO TO 20 170 CONTINUE C ********** NOW BALANCE THE SUBMATRIX IN ROWS K TO L ********** DO 180 I = K, L 180 SCALE(I) = 1.D0 C ********** ITERATIVE LOOP FOR NORM REDUCTION ********** 190 NOCONV = .FALSE. C DO 270 I = K, L C = 0.D0 R = 0.D0 C DO 200 J = K, L IF (J .EQ. I) GO TO 200 C = C + DABS(A(J,I)) R = R + DABS(A(I,J)) 200 CONTINUE C ********** GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ********** IF (C .EQ. 0.D0 .OR. R .EQ. 0.D0) GO TO 270 G = R / RADIX F = 1.D0 S = C + R 210 IF (C .GE. G) GO TO 220 F = F * RADIX C = C * B2 GO TO 210 220 G = R * RADIX 230 IF (C .LT. G) GO TO 240 F = F / RADIX C = C / B2 GO TO 230 C ********** NOW BALANCE ********** 240 IF ((C + R) / F .GE. 0.95D0 * S) GO TO 270 G = 1.D0 / F SCALE(I) = SCALE(I) * F NOCONV = .TRUE. C DO 250 J = K, N 250 A(I,J) = A(I,J) * G C DO 260 J = 1, L 260 A(J,I) = A(J,I) * F C 270 CONTINUE C IF (NOCONV) GO TO 190 C 280 LOW = K IGH = L RETURN END SUBROUTINE DBALNV (NZ,N,Z,LOW,IGH,SCALE) INTEGER I,J,K,N,II,NZ,IGH,LOW DOUBLE PRECISION Z(NZ,N),SCALE(N) DOUBLE PRECISION S C----------------------------------------------------------------------- C GIVEN A MATRIX A OF ORDER N. DBAL TRANSFORMS A INTO C THE MATRIX B BY THE SIMILARITY TRANSFORMATION C B = D**(-1)*TRANSPOSE(P)*A*P*D C WHERE D IS A DIAGONAL MATRIX AND P A PERMUTATION MATRIX. C THE INFORMATION CONCERNING D AND P IS STORED IN IGH, LOW, C AND SCALE. THE ORDER IN WHICH THE INTERCHANGES WERE MADE C IS N TO IGH + 1, AND THEN 1 TO LOW - 1. C C Z IS A MATRIX OF ORDER N. DBALNV TRANSFORMS Z INTO THE C MATRIX W USING THE INVERSE SIMILARITY TRANSFORM C W = P*D*Z*D**(-1)*TRANSPOSE(P) C C ON INPUT- C C NZ IS THE ROW DIMENSION OF THE MATRIX Z IN THE CALLING C PROGRAM, C C N IS THE ORDER OF THE MATRIX, C C LOW AND IGH ARE INTEGERS DETERMINED BY DBAL, C C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS C AND SCALING FACTORS USED BY DBAL, C C ON OUTPUT- C C Z CONTAINS THE TRANSFORMED MATRIX W C C----------------------------------------------------------------------- C IF (IGH .EQ. LOW) GO TO 30 C DO 11 I = LOW, IGH S = SCALE(I) DO 10 J = 1, N 10 Z(I,J) = Z(I,J) * S 11 CONTINUE C DO 21 J = LOW, IGH S = 1.D0/SCALE(J) DO 20 I = 1, N 20 Z(I,J) = Z(I,J) * S 21 CONTINUE C C ********- FOR I=LOW-1 STEP -1 UNTIL 1, C IGH+1 STEP 1 UNTIL N DO -- ********** C 30 DO 60 II = 1, N I = II IF (I .GE. LOW .AND. I .LE. IGH) GO TO 60 IF (I .LT. LOW) I = LOW - II K = SCALE(I) IF (K .EQ. I) GO TO 60 C DO 40 J = 1, N S = Z(I,J) Z(I,J) = Z(K,J) 40 Z(K,J) = S C DO 50 J = 1, N S = Z(J,I) Z(J,I) = Z(J,K) 50 Z(J,K) = S 60 CONTINUE RETURN END SUBROUTINE DORTH(NM,N,LOW,IGH,A,ORT) C INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW DOUBLE PRECISION A(NM,N),ORT(IGH) DOUBLE PRECISION F,G,H,SCALE C DOUBLE PRECISION DSQRT,DABS C----------------------------------------------------------------------- C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ORTHES, C NUM. MATH. 12, 349-368(1968) BY MARTIN AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). C C GIVEN A REAL GENERAL MATRIX, THIS SUBROUTINE C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY C ORTHOGONAL SIMILARITY TRANSFORMATIONS. C C ON INPUT- C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C N IS THE ORDER OF THE MATRIX, C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE DBAL. IF DBAL HAS NOT BEEN USED THEN C SET LOW=1, IGH=N, C C A CONTAINS THE INPUT MATRIX. C C ON OUTPUT- C C A CONTAINS THE HESSENBERG MATRIX. INFORMATION ABOUT C THE ORTHOGONAL TRANSFORMATIONS USED IN THE REDUCTION C IS STORED IN THE REMAINING TRIANGLE UNDER THE C HESSENBERG MATRIX, C C ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANSFORMATIONS. C ONLY ELEMENTS LOW THROUGH IGH ARE USED. C C----------------------------------------------------------------------- C LA = IGH - 1 KP1 = LOW + 1 IF (LA .LT. KP1) GO TO 200 C DO 180 M = KP1, LA H = 0.D0 ORT(M) = 0.D0 SCALE = 0.D0 C ********** SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ********** DO 90 I = M, IGH 90 SCALE = SCALE + DABS(A(I,M-1)) C IF (SCALE .EQ. 0.D0) GO TO 180 MP = M + IGH C ********** FOR I=IGH STEP -1 UNTIL M DO -- ********** DO 100 II = M, IGH I = MP - II ORT(I) = A(I,M-1) / SCALE H = H + ORT(I) * ORT(I) 100 CONTINUE C G = DSQRT(H) IF (ORT(M) .GE. 0.D0) G = -G H = H - ORT(M) * G ORT(M) = ORT(M) - G C ********** FORM (I-(U*UT)/H) * A ********** DO 130 J = M, N F = 0.D0 C ********** FOR I=IGH STEP -1 UNTIL M DO -- ********** DO 110 II = M, IGH I = MP - II F = F + ORT(I) * A(I,J) 110 CONTINUE C F = F / H C DO 120 I = M, IGH 120 A(I,J) = A(I,J) - F * ORT(I) C 130 CONTINUE C ********** FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ********** DO 160 I = 1, IGH F = 0.D0 C ********** FOR J=IGH STEP -1 UNTIL M DO -- ********** DO 140 JJ = M, IGH J = MP - JJ F = F + ORT(J) * A(I,J) 140 CONTINUE C F = F / H C DO 150 J = M, IGH 150 A(I,J) = A(I,J) - F * ORT(J) C 160 CONTINUE C ORT(M) = SCALE * ORT(M) A(M,M-1) = SCALE * G 180 CONTINUE C 200 RETURN END SUBROUTINE DHQR(NM,N,LOW,IGH,H,WR,WI,IERR) C INTEGER I,J,K,L,M,N,EN,LL,MM,NA,NM,IGH,ITS,LOW,MP2,ENM2,IERR DOUBLE PRECISION H(NM,N),WR(N),WI(N) DOUBLE PRECISION P,Q,R,S,T,W,X,Y,ZZ,NORM,MACHEP,DPMPAR C DOUBLE PRECISION DSQRT,DABS C INTEGER MIN0 LOGICAL NOTLAS C----------------------------------------------------------------------- C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE HQR, C NUM. MATH. 14, 219-231(1970) BY MARTIN, PETERS, AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 359-371(1971). C C DHQR FINDS THE EIGENVALUES OF A DOUBLE PRECISION REAL C UPPER HESSENBERG MATRIX BY THE QR METHOD. C C ON INPUT- C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C N IS THE ORDER OF THE MATRIX, C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE DBAL. IF DBAL HAS NOT BEEN USED THEN C SET LOW=1, IGH=N, C C H CONTAINS THE UPPER HESSENBERG MATRIX. INFORMATION ABOUT C THE TRANSFORMATIONS USED IN THE REDUCTION TO HESSENBERG C FORM BY DORTH, IF PERFORMED, IS STORED C IN THE REMAINING TRIANGLE UNDER THE HESSENBERG MATRIX. C C ON OUTPUT- C C H HAS BEEN DESTROYED. THEREFORE, IT MUST BE SAVED C BEFORE CALLING HQR IF SUBSEQUENT CALCULATION AND C BACK TRANSFORMATION OF EIGENVECTORS IS TO BE PERFORMED, C C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE EIGENVALUES. THE EIGENVALUES C ARE UNORDERED EXCEPT THAT COMPLEX CONJUGATE PAIRS C OF VALUES APPEAR CONSECUTIVELY WITH THE EIGENVALUE C HAVING THE POSITIVE IMAGINARY PART FIRST. IF AN C ERROR EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT C FOR INDICES IERR+1,...,N, C C IERR IS SET TO C ZERO FOR NORMAL RETURN, C J IF THE J-TH EIGENVALUE HAS NOT BEEN C DETERMINED AFTER 50 ITERATIONS. C C----------------------------------------------------------------------- C C ********** MACHEP IS A MACHINE DEPENDENT PARAMETER. ASSIGN C MACHEP THE VALUE U WHERE U IS THE SMALLEST POSITIVE C FLOATING POINT NUMBER SUCH THAT 1.0 + U .GT. 1.0 C IN THE DOUBLE PRECISION ARITHMETIC BEING USED. C MACHEP = DPMPAR(1) C C ********** C IERR = 0 NORM = 0.D0 K = 1 C ********** STORE ROOTS ISOLATED BY DBAL C AND COMPUTE MATRIX NORM ********** DO 50 I = 1, N C DO 40 J = K, N 40 NORM = NORM + DABS(H(I,J)) C K = I IF (I .GE. LOW .AND. I .LE. IGH) GO TO 50 WR(I) = H(I,I) WI(I) = 0.D0 50 CONTINUE C EN = IGH T = 0.D0 C ********** SEARCH FOR NEXT EIGENVALUES ********** 60 IF (EN .LT. LOW) GO TO 1001 ITS = 0 NA = EN - 1 ENM2 = NA - 1 C ********** LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT C FOR L=EN STEP -1 UNTIL LOW DO -- ********** 70 DO 80 LL = LOW, EN L = EN + LOW - LL IF (L .EQ. LOW) GO TO 100 S = DABS(H(L-1,L-1)) + DABS(H(L,L)) IF (S .EQ. 0.D0) S = NORM IF (DABS(H(L,L-1)) .LE. MACHEP * S) GO TO 100 80 CONTINUE C ********** FORM SHIFT ********** 100 X = H(EN,EN) IF (L .EQ. EN) GO TO 270 Y = H(NA,NA) W = H(EN,NA) * H(NA,EN) IF (L .EQ. NA) GO TO 280 IF (ITS .EQ. 50) GO TO 1000 IF (ITS .NE. 10 .AND. ITS .NE. 20 .AND. ITS .NE. 30) GO TO 130 C ********** FORM EXCEPTIONAL SHIFT ********** T = T + X C DO 120 I = LOW, EN 120 H(I,I) = H(I,I) - X C S = DABS(H(EN,NA)) + DABS(H(NA,ENM2)) X = .75D0 * S Y = X W = -.4375D0 * S * S 130 ITS = ITS + 1 C ********** LOOK FOR TWO CONSECUTIVE SMALL C SUB-DIAGONAL ELEMENTS. C FOR M=EN-2 STEP -1 UNTIL L DO -- ********** DO 140 MM = L, ENM2 M = ENM2 + L - MM ZZ = H(M,M) R = X - ZZ S = Y - ZZ P = (R * S - W) / H(M+1,M) + H(M,M+1) Q = H(M+1,M+1) - ZZ - R - S R = H(M+2,M+1) S = DABS(P) + DABS(Q) + DABS(R) P = P / S Q = Q / S R = R / S IF (M .EQ. L) GO TO 150 IF (DABS(H(M,M-1)) * (DABS(Q) + DABS(R)) .LE. MACHEP * DABS(P) X * (DABS(H(M-1,M-1)) + DABS(ZZ) + DABS(H(M+1,M+1)))) GO TO 150 140 CONTINUE C 150 MP2 = M + 2 C DO 160 I = MP2, EN H(I,I-2) = 0.D0 IF (I .EQ. MP2) GO TO 160 H(I,I-3) = 0.D0 160 CONTINUE C ********** DOUBLE QR STEP INVOLVING ROWS L TO EN AND C COLUMNS M TO EN ********** DO 260 K = M, NA NOTLAS = K .NE. NA IF (K .EQ. M) GO TO 170 P = H(K,K-1) Q = H(K+1,K-1) R = 0.D0 IF (NOTLAS) R = H(K+2,K-1) X = DABS(P) + DABS(Q) + DABS(R) IF (X .EQ. 0.D0) GO TO 260 P = P / X Q = Q / X R = R / X 170 S = DSQRT(P*P + Q*Q + R*R) IF (P .LT. 0.D0) S = -S IF (K .EQ. M) GO TO 180 H(K,K-1) = -S * X GO TO 190 180 IF (L .NE. M) H(K,K-1) = -H(K,K-1) 190 P = P + S X = P / S Y = Q / S ZZ = R / S Q = Q / P R = R / P C ********** ROW MODIFICATION ********** DO 210 J = K, EN P = H(K,J) + Q * H(K+1,J) IF (.NOT. NOTLAS) GO TO 200 P = P + R * H(K+2,J) H(K+2,J) = H(K+2,J) - P * ZZ 200 H(K+1,J) = H(K+1,J) - P * Y H(K,J) = H(K,J) - P * X 210 CONTINUE C J = MIN0(EN,K+3) C ********** COLUMN MODIFICATION ********** DO 230 I = L, J P = X * H(I,K) + Y * H(I,K+1) IF (.NOT. NOTLAS) GO TO 220 P = P + ZZ * H(I,K+2) H(I,K+2) = H(I,K+2) - P * R 220 H(I,K+1) = H(I,K+1) - P * Q H(I,K) = H(I,K) - P 230 CONTINUE C 260 CONTINUE C GO TO 70 C ********** ONE ROOT FOUND ********** 270 WR(EN) = X + T WI(EN) = 0.D0 EN = NA GO TO 60 C ********** TWO ROOTS FOUND ********** 280 P = (Y - X) / 2.D0 Q = P * P + W ZZ = DSQRT(DABS(Q)) X = X + T IF (Q .LT. 0.D0) GO TO 320 C ********** REAL PAIR ********** IF (P .LT. 0.D0) ZZ = -ZZ ZZ = P + ZZ WR(NA) = X + ZZ WR(EN) = WR(NA) IF (ZZ .NE. 0.D0) WR(EN) = X - W / ZZ WI(NA) = 0.D0 WI(EN) = 0.D0 GO TO 330 C ********** COMPLEX PAIR ********** 320 WR(NA) = X + P WR(EN) = X + P WI(NA) = ZZ WI(EN) = -ZZ 330 EN = ENM2 GO TO 60 C ********** SET ERROR -- NO CONVERGENCE TO AN C EIGENVALUE AFTER 50 ITERATIONS ********** 1000 IERR = EN 1001 RETURN END SUBROUTINE DBABK(NM,N,LOW,IGH,SCALE,M,Z) C INTEGER I,J,K,M,N,II,NM,IGH,LOW DOUBLE PRECISION SCALE(N),Z(NM,M) DOUBLE PRECISION S C----------------------------------------------------------------------- C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE BALBAK, C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). C C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A REAL GENERAL C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING C BALANCED MATRIX DETERMINED BY DBAL. C C ON INPUT- C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C N IS THE ORDER OF THE MATRIX, C C LOW AND IGH ARE INTEGERS DETERMINED BY DBAL, C C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS C AND SCALING FACTORS USED BY DBAL, C C M IS THE NUMBER OF COLUMNS OF Z TO BE BACK TRANSFORMED, C C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGEN- C VECTORS TO BE BACK TRANSFORMED IN ITS FIRST M COLUMNS. C C ON OUTPUT- C C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE C TRANSFORMED EIGENVECTORS IN ITS FIRST M COLUMNS. C C----------------------------------------------------------------------- C IF (M .EQ. 0) GO TO 200 IF (IGH .EQ. LOW) GO TO 120 C DO 110 I = LOW, IGH S = SCALE(I) C ********** LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED C IF THE FOREGOING STATEMENT IS REPLACED BY C S=1.0/SCALE(I). ********** DO 100 J = 1, M 100 Z(I,J) = Z(I,J) * S C 110 CONTINUE C ********- FOR I=LOW-1 STEP -1 UNTIL 1, C IGH+1 STEP 1 UNTIL N DO -- ********** 120 DO 140 II = 1, N I = II IF (I .GE. LOW .AND. I .LE. IGH) GO TO 140 IF (I .LT. LOW) I = LOW - II K = SCALE(I) IF (K .EQ. I) GO TO 140 C DO 130 J = 1, M S = Z(I,J) Z(I,J) = Z(K,J) Z(K,J) = S 130 CONTINUE C 140 CONTINUE C 200 RETURN END SUBROUTINE DORTRN(NM,N,LOW,IGH,A,ORT,Z) C INTEGER I,J,N,KL,MM,MP,NM,IGH,LOW,MP1 DOUBLE PRECISION A(NM,IGH),ORT(IGH),Z(NM,N) DOUBLE PRECISION G C----------------------------------------------------------------------- C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ORTRANS, C NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). C C THIS SUBROUTINE ACCUMULATES THE ORTHOGONAL SIMILARITY C TRANSFORMATIONS USED IN THE REDUCTION OF A REAL DOUBLE C PRECISION MATRIX TO UPPER HESSENBERG FORM BY DORTH. C C ON INPUT- C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C N IS THE ORDER OF THE MATRIX, C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE DBAL. IF DBAL HAS NOT BEEN USED THEN C SET LOW=1, IGH=N, C C A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS- C FORMATIONS USED IN THE REDUCTION BY DORTH C IN ITS STRICT LOWER TRIANGLE, C C ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANS- C FORMATIONS USED IN THE REDUCTION BY DORTH. C ONLY ELEMENTS LOW THROUGH IGH ARE USED. C C ON OUTPUT- C C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE C REDUCTION BY DORTH, C C ORT HAS BEEN ALTERED. C C----------------------------------------------------------------------- C C ********** INITIALIZE Z TO IDENTITY MATRIX ********** DO 80 I = 1, N C DO 60 J = 1, N 60 Z(I,J) = 0.D0 C Z(I,I) = 1.D0 80 CONTINUE C KL = IGH - LOW - 1 IF (KL .LT. 1) GO TO 200 C ********** FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- ********** DO 140 MM = 1, KL MP = IGH - MM IF (A(MP,MP-1) .EQ. 0.D0) GO TO 140 MP1 = MP + 1 C DO 100 I = MP1, IGH 100 ORT(I) = A(I,MP-1) C DO 130 J = MP, IGH G = 0.D0 C DO 110 I = MP, IGH 110 G = G + ORT(I) * Z(I,J) C ********** DIVISOR BELOW IS NEGATIVE OF H FORMED IN ORTHES. C DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ********** G = (G / ORT(MP)) / A(MP,MP-1) C DO 120 I = MP, IGH 120 Z(I,J) = Z(I,J) + G * ORT(I) C 130 CONTINUE C 140 CONTINUE C 200 RETURN END SUBROUTINE DRTRN1(N,LOW,IGH,A,NA,Z,NZ,ORT) C INTEGER I,J,N,KL,MM,MP,NA,IGH,LOW,MP1,NZ DOUBLE PRECISION A(NA,IGH),ORT(IGH),Z(NZ,N) DOUBLE PRECISION G C----------------------------------------------------------------------- C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE ORTRANS, C NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). C C THIS SUBROUTINE ACCUMULATES THE ORTHOGONAL SIMILARITY C TRANSFORMATIONS USED IN THE REDUCTION OF A REAL DOUBLE C PRECISION MATRIX TO UPPER HESSENBERG FORM BY DORTH. C C ON INPUT- C C N IS THE ORDER OF THE MATRIX, C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE DBAL. IF DBAL HAS NOT BEEN USED THEN C SET LOW=1, IGH=N, C C A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS- C FORMATIONS USED IN THE REDUCTION BY DORTH C IN ITS STRICT LOWER TRIANGLE, C C NA MUST BE SET TO THE ROW DIMENSION OF THE 2-DIMENSIONAL C ARRAY PARAMETER A AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C NZ MUST BE SET TO THE ROW DIMENSION OF THE 2-DIMENSIONAL C ARRAY PARAMETER Z AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C ORT CONTAINS FURTHER INFORMATION ABOUT THE TRANS- C FORMATIONS USED IN THE REDUCTION BY DORTH. C ONLY ELEMENTS LOW THROUGH IGH ARE USED. C C ON OUTPUT- C C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE C REDUCTION BY DORTH, C C ORT HAS BEEN ALTERED. C C----------------------------------------------------------------------- C C ********** INITIALIZE Z TO IDENTITY MATRIX ********** DO 80 I = 1, N C DO 60 J = 1, N 60 Z(I,J) = 0.D0 C Z(I,I) = 1.D0 80 CONTINUE C KL = IGH - LOW - 1 IF (KL .LT. 1) GO TO 200 C ********** FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- ********** DO 140 MM = 1, KL MP = IGH - MM IF (A(MP,MP-1) .EQ. 0.D0) GO TO 140 MP1 = MP + 1 C DO 100 I = MP1, IGH 100 ORT(I) = A(I,MP-1) C DO 130 J = MP, IGH G = 0.D0 C DO 110 I = MP, IGH 110 G = G + ORT(I) * Z(I,J) C ********** DIVISOR BELOW IS NEGATIVE OF H FORMED IN ORTHES. C DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ********** G = (G / ORT(MP)) / A(MP,MP-1) C DO 120 I = MP, IGH 120 Z(I,J) = Z(I,J) + G * ORT(I) C 130 CONTINUE C 140 CONTINUE C 200 RETURN END SUBROUTINE DHQR2(NM,N,LOW,IGH,H,WR,WI,Z,IERR) C INTEGER I,J,K,L,M,N,EN,II,JJ,LL,MM,NA,NM,NN, X IGH,ITS,LOW,MP2,ENM2,IERR DOUBLE PRECISION H(NM,N),WR(N),WI(N),Z(NM,N) DOUBLE PRECISION A,B,D,P,Q,R,S,T,U,W,X,Y DOUBLE PRECISION RA,SA,VI,VR,ZZ,NORM,MACHEP C INTEGER MIN0 C DOUBLE PRECISION DSQRT,DABS DOUBLE PRECISION DPMPAR LOGICAL NOTLAS C----------------------------------------------------------------------- C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE HQR2, C NUM. MATH. 16, 181-204(1970) BY PETERS AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). C C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS C OF A REAL DOUBLE PRECISION UPPER HESSENBERG MATRIX BY THE C QR METHOD. THE EIGENVECTORS OF A REAL GENERAL MATRIX CAN C ALSO BE FOUND IF DORTH AND DORTRN HAVE BEEN USED TO REDUCE C THIS GENERAL MATRIX TO HESSENBERG FORM AND TO ACCUMULATE C THE SIMILARITY TRANSFORMATIONS. C C ON INPUT- C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C N IS THE ORDER OF THE MATRIX, C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE DBAL. IF DBAL HAS NOT BEEN USED THEN C SET LOW=1, IGH=N, C C H CONTAINS THE UPPER HESSENBERG MATRIX, C C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED BY DORTRN C AFTER THE REDUCTION BY DORTH, IF PERFORMED. IF THE C EIGENVECTORS OF THE HESSENBERG MATRIX ARE DESIRED, C Z MUST CONTAIN THE IDENTITY MATRIX. C C ON OUTPUT- C C H HAS BEEN DESTROYED, C C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE EIGENVALUES. THE EIGENVALUES C ARE UNORDERED EXCEPT THAT COMPLEX CONJUGATE PAIRS C OF VALUES APPEAR CONSECUTIVELY WITH THE EIGENVALUE C HAVING THE POSITIVE IMAGINARY PART FIRST. IF AN C ERROR EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT C FOR INDICES IERR+1,...,N, C C Z CONTAINS THE REAL AND IMAGINARY PARTS OF THE EIGENVECTORS. C IF THE I-TH EIGENVALUE IS REAL, THE I-TH COLUMN OF Z C CONTAINS ITS EIGENVECTOR. IF THE I-TH EIGENVALUE IS COMPLEX C WITH POSITIVE IMAGINARY PART, THE I-TH AND (I+1)-TH C COLUMNS OF Z CONTAIN THE REAL AND IMAGINARY PARTS OF ITS C EIGENVECTOR. THE EIGENVECTORS ARE UNNORMALIZED. IF AN C ERROR EXIT IS MADE, NONE OF THE EIGENVECTORS HAS BEEN FOUND, C C IERR IS SET TO C ZERO FOR NORMAL RETURN, C J IF THE J-TH EIGENVALUE HAS NOT BEEN C DETERMINED AFTER 50 ITERATIONS. C C----------------------------------------------------------------------- C C ********** MACHEP IS A MACHINE DEPENDENT PARAMETER. ASSIGN C MACHEP THE VALUE U WHERE U IS THE SMALLEST POSITIVE C FLOATING POINT NUMBER SUCH THAT 1.0 + U .GT. 1.0 C IN THE DOUBLE PRECISION ARITHMETIC BEING USED. C MACHEP = DPMPAR(1) C C ********** C IERR = 0 NORM = 0.D0 K = 1 C ********** STORE ROOTS ISOLATED BY DBAL C AND COMPUTE MATRIX NORM ********** DO 50 I = 1, N C DO 40 J = K, N 40 NORM = NORM + DABS(H(I,J)) C K = I IF (I .GE. LOW .AND. I .LE. IGH) GO TO 50 WR(I) = H(I,I) WI(I) = 0.D0 50 CONTINUE C EN = IGH T = 0.D0 C ********** SEARCH FOR NEXT EIGENVALUES ********** 60 IF (EN .LT. LOW) GO TO 340 ITS = 0 NA = EN - 1 ENM2 = NA - 1 C ********** LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT C FOR L=EN STEP -1 UNTIL LOW DO -- ********** 70 DO 80 LL = LOW, EN L = EN + LOW - LL IF (L .EQ. LOW) GO TO 100 S = DABS(H(L-1,L-1)) + DABS(H(L,L)) IF (S .EQ. 0.D0) S = NORM IF (DABS(H(L,L-1)) .LE. MACHEP * S) GO TO 100 80 CONTINUE C ********** FORM SHIFT ********** 100 X = H(EN,EN) IF (L .EQ. EN) GO TO 270 Y = H(NA,NA) W = H(EN,NA) * H(NA,EN) IF (L .EQ. NA) GO TO 280 IF (ITS .EQ. 50) GO TO 1000 IF (ITS .NE. 10 .AND. ITS .NE. 20 .AND. ITS .NE. 30) GO TO 130 C ********** FORM EXCEPTIONAL SHIFT ********** T = T + X C DO 120 I = LOW, EN 120 H(I,I) = H(I,I) - X C S = DABS(H(EN,NA)) + DABS(H(NA,ENM2)) X = .75D0 * S Y = X W = -.4375D0 * S * S 130 ITS = ITS + 1 C ********** LOOK FOR TWO CONSECUTIVE SMALL C SUB-DIAGONAL ELEMENTS. C FOR M=EN-2 STEP -1 UNTIL L DO -- ********** DO 140 MM = L, ENM2 M = ENM2 + L - MM ZZ = H(M,M) R = X - ZZ S = Y - ZZ P = (R * S - W) / H(M+1,M) + H(M,M+1) Q = H(M+1,M+1) - ZZ - R - S R = H(M+2,M+1) S = DABS(P) + DABS(Q) + DABS(R) P = P / S Q = Q / S R = R / S IF (M .EQ. L) GO TO 150 IF (DABS(H(M,M-1)) * (DABS(Q) + DABS(R)) .LE. MACHEP * DABS(P) X * (DABS(H(M-1,M-1)) + DABS(ZZ) + DABS(H(M+1,M+1)))) GO TO 150 140 CONTINUE C 150 MP2 = M + 2 C DO 160 I = MP2, EN H(I,I-2) = 0.D0 IF (I .EQ. MP2) GO TO 160 H(I,I-3) = 0.D0 160 CONTINUE C ********** DOUBLE QR STEP INVOLVING ROWS L TO EN AND C COLUMNS M TO EN ********** DO 260 K = M, NA NOTLAS = K .NE. NA IF (K .EQ. M) GO TO 170 P = H(K,K-1) Q = H(K+1,K-1) R = 0.D0 IF (NOTLAS) R = H(K+2,K-1) X = DABS(P) + DABS(Q) + DABS(R) IF (X .EQ. 0.D0) GO TO 260 P = P / X Q = Q / X R = R / X 170 S = DSQRT(P*P + Q*Q + R*R) IF (P .LT. 0.D0) S = -S IF (K .EQ. M) GO TO 180 H(K,K-1) = -S * X GO TO 190 180 IF (L .NE. M) H(K,K-1) = -H(K,K-1) 190 P = P + S X = P / S Y = Q / S ZZ = R / S Q = Q / P R = R / P C ********** ROW MODIFICATION ********** DO 210 J = K, N P = H(K,J) + Q * H(K+1,J) IF (.NOT. NOTLAS) GO TO 200 P = P + R * H(K+2,J) H(K+2,J) = H(K+2,J) - P * ZZ 200 H(K+1,J) = H(K+1,J) - P * Y H(K,J) = H(K,J) - P * X 210 CONTINUE C J = MIN0(EN,K+3) C ********** COLUMN MODIFICATION ********** DO 230 I = 1, J P = X * H(I,K) + Y * H(I,K+1) IF (.NOT. NOTLAS) GO TO 220 P = P + ZZ * H(I,K+2) H(I,K+2) = H(I,K+2) - P * R 220 H(I,K+1) = H(I,K+1) - P * Q H(I,K) = H(I,K) - P 230 CONTINUE C ********** ACCUMULATE TRANSFORMATIONS ********** DO 250 I = LOW, IGH P = X * Z(I,K) + Y * Z(I,K+1) IF (.NOT. NOTLAS) GO TO 240 P = P + ZZ * Z(I,K+2) Z(I,K+2) = Z(I,K+2) - P * R 240 Z(I,K+1) = Z(I,K+1) - P * Q Z(I,K) = Z(I,K) - P 250 CONTINUE C 260 CONTINUE C GO TO 70 C ********** ONE ROOT FOUND ********** 270 H(EN,EN) = X + T WR(EN) = H(EN,EN) WI(EN) = 0.D0 EN = NA GO TO 60 C ********** TWO ROOTS FOUND ********** 280 P = (Y - X) / 2.D0 Q = P * P + W ZZ = DSQRT(DABS(Q)) H(EN,EN) = X + T X = H(EN,EN) H(NA,NA) = Y + T IF (Q .LT. 0.D0) GO TO 320 C ********** REAL PAIR ********** IF (P .LT. 0.D0) ZZ = -ZZ ZZ = P + ZZ WR(NA) = X + ZZ WR(EN) = WR(NA) IF (ZZ .NE. 0.D0) WR(EN) = X - W / ZZ WI(NA) = 0.D0 WI(EN) = 0.D0 X = H(EN,NA) S = DABS(X) + DABS(ZZ) P = X / S Q = ZZ / S R = DSQRT(P*P+Q*Q) P = P / R Q = Q / R C ********** ROW MODIFICATION ********** DO 290 J = NA, N ZZ = H(NA,J) H(NA,J) = Q * ZZ + P * H(EN,J) H(EN,J) = Q * H(EN,J) - P * ZZ 290 CONTINUE C ********** COLUMN MODIFICATION ********** DO 300 I = 1, EN ZZ = H(I,NA) H(I,NA) = Q * ZZ + P * H(I,EN) H(I,EN) = Q * H(I,EN) - P * ZZ 300 CONTINUE C ********** ACCUMULATE TRANSFORMATIONS ********** DO 310 I = LOW, IGH ZZ = Z(I,NA) Z(I,NA) = Q * ZZ + P * Z(I,EN) Z(I,EN) = Q * Z(I,EN) - P * ZZ 310 CONTINUE C GO TO 330 C ********** COMPLEX PAIR ********** 320 WR(NA) = X + P WR(EN) = X + P WI(NA) = ZZ WI(EN) = -ZZ 330 EN = ENM2 GO TO 60 C ********** ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND C VECTORS OF UPPER TRIANGULAR FORM ********** 340 IF (NORM .EQ. 0.D0) GO TO 1001 C ********** FOR EN=N STEP -1 UNTIL 1 DO -- ********** DO 800 NN = 1, N EN = N + 1 - NN P = WR(EN) Q = WI(EN) NA = EN - 1 IF (Q) 710, 600, 800 C ********** REAL VECTOR ********** 600 M = EN H(EN,EN) = 1.D0 IF (NA .EQ. 0) GO TO 800 C ********** FOR I=EN-1 STEP -1 UNTIL 1 DO -- ********** DO 700 II = 1, NA I = EN - II W = H(I,I) - P R = H(I,EN) IF (M .GT. NA) GO TO 620 C DO 610 J = M, NA 610 R = R + H(I,J) * H(J,EN) C 620 IF (WI(I) .GE. 0.D0) GO TO 630 ZZ = W S = R GO TO 700 630 M = I IF (WI(I) .NE. 0.D0) GO TO 640 T = W IF (W .EQ. 0.D0) T = MACHEP * NORM H(I,EN) = -R / T GO TO 700 C ********** SOLVE REAL EQUATIONS ********** 640 X = H(I,I+1) Y = H(I+1,I) Q = (WR(I) - P) * (WR(I) - P) + WI(I) * WI(I) T = (X * S - ZZ * R) / Q H(I,EN) = T IF (DABS(X) .LE. DABS(ZZ)) GO TO 650 H(I+1,EN) = (-R - W * T) / X GO TO 700 650 H(I+1,EN) = (-S - Y * T) / ZZ 700 CONTINUE C ********** END REAL VECTOR ********** GO TO 800 C ********** COMPLEX VECTOR ********** 710 M = NA C ********** LAST VECTOR COMPONENT CHOSEN IMAGINARY SO THAT C EIGENVECTOR MATRIX IS TRIANGULAR ********** IF (DABS(H(EN,NA)) .LE. DABS(H(NA,EN))) GO TO 720 H(NA,NA) = Q / H(EN,NA) H(NA,EN) = -(H(EN,EN) - P) / H(EN,NA) GO TO 730 720 U = H(NA,NA) - P B = -H(NA,EN) / (U * U + Q * Q) H(NA,NA) = B * Q H(NA,EN) = B * U 730 H(EN,NA) = 0.D0 H(EN,EN) = 1.D0 ENM2 = NA - 1 IF (ENM2 .EQ. 0) GO TO 800 C ********** FOR I=EN-2 STEP -1 UNTIL 1 DO -- ********** DO 790 II = 1, ENM2 I = NA - II W = H(I,I) - P RA = 0.D0 SA = H(I,EN) C DO 760 J = M, NA RA = RA + H(I,J) * H(J,NA) SA = SA + H(I,J) * H(J,EN) 760 CONTINUE C IF (WI(I) .GE. 0.D0) GO TO 770 ZZ = W R = RA S = SA GO TO 790 770 M = I IF (WI(I) .NE. 0.D0) GO TO 780 D = W * W + Q * Q H(I,NA) = -(RA * W + SA * Q) / D H(I,EN) = (RA * Q - SA * W) / D GO TO 790 C ********** SOLVE COMPLEX EQUATIONS ********** 780 X = H(I,I+1) Y = H(I+1,I) VR = (WR(I) - P) * (WR(I) - P) + WI(I) * WI(I) - Q * Q VI = (WR(I) - P) * 2.D0 * Q IF (VR .EQ. 0.D0 .AND. VI .EQ. 0.D0) VR = MACHEP * NORM X * (DABS(W) + DABS(Q) + DABS(X) + DABS(Y) + DABS(ZZ)) A = X * R - ZZ * RA + Q * SA B = X * S - ZZ * SA - Q * RA D = VR * VR + VI * VI H(I,NA) = (A * VR + B * VI) / D H(I,EN) = (B * VR - A * VI) / D IF (DABS(X) .LE. DABS(ZZ) + DABS(Q)) GO TO 785 H(I+1,NA) = (-RA - W * H(I,NA) + Q * H(I,EN)) / X H(I+1,EN) = (-SA - W * H(I,EN) - Q * H(I,NA)) / X GO TO 790 785 A = -R - Y * H(I,NA) B = -S - Y * H(I,EN) D = ZZ * ZZ + Q * Q H(I+1,NA) = (A * ZZ + B * Q) / D H(I+1,EN) = (B * ZZ - A * Q) / D 790 CONTINUE C ********** END COMPLEX VECTOR ********** 800 CONTINUE C ********** END BACK SUBSTITUTION. C VECTORS OF ISOLATED ROOTS ********** DO 840 I = 1, N IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840 C DO 820 J = I, N 820 Z(I,J) = H(I,J) C 840 CONTINUE C ********** MULTIPLY BY TRANSFORMATION MATRIX TO GIVE C VECTORS OF ORIGINAL FULL MATRIX. C FOR J=N STEP -1 UNTIL LOW DO -- ********** DO 880 JJ = LOW, N J = N + LOW - JJ M = MIN0(J,IGH) C DO 880 I = LOW, IGH ZZ = 0.D0 C DO 860 K = LOW, M 860 ZZ = ZZ + Z(I,K) * H(K,J) C Z(I,J) = ZZ 880 CONTINUE C GO TO 1001 C ********** SET ERROR -- NO CONVERGENCE TO AN C EIGENVALUE AFTER 50 ITERATIONS ********** 1000 IERR = EN 1001 RETURN END SUBROUTINE SEIG (A, KA, N, W, T, IERR) C----------------------------------------------------------------------- C EIGENVALUES OF SYMMETRIC REAL MATRICES C----------------------------------------------------------------------- REAL A(*), W(N), T(*) C IF (KA .EQ. 0) GO TO 10 CALL TRED1 (KA, N, A, W, T(N+1), T(1)) CALL TQLRAT (N, W, T, IERR) RETURN 10 L = N*(N + 1) L = L/2 CALL TRED3 (N, L, A, W, T(N+1), T(1)) CALL TQLRAT (N, W, T, IERR) RETURN END SUBROUTINE SEIG1 (A, KA, N, W, T, IERR) C----------------------------------------------------------------------- C EIGENVALUES OF SYMMETRIC REAL MATRICES C----------------------------------------------------------------------- REAL A(*), W(N), T(N) C IF (KA .EQ. 0) GO TO 10 CALL TRED1 (KA, N, A, W, T, T) CALL IMTQL1 (N, W, T, IERR) RETURN 10 L = N*(N + 1) L = L/2 CALL TRED3 (N, L, A, W, T, T) CALL IMTQL1 (N, W, T, IERR) RETURN END SUBROUTINE SEIGV (A, KA, N, W, Z, T, IERR) C----------------------------------------------------------------------- C EIGENVALUES AND EIGENVECTORS OF SYMMETRIC REAL MATRICES C----------------------------------------------------------------------- REAL A(KA,N), W(N), Z(KA,N), T(N) C CALL TRED2 (KA, N, A, W, T, Z) CALL TQL2 (KA, N, W, T, Z, IERR) RETURN END SUBROUTINE SEIGV1 (A, KA, N, W, Z, T, IERR) C----------------------------------------------------------------------- C EIGENVALUES AND EIGENVECTORS OF SYMMETRIC REAL MATRICES C----------------------------------------------------------------------- REAL A(KA,N), W(N), Z(KA,N), T(N) C CALL TRED2 (KA, N, A, W, T, Z) CALL IMTQL2 (KA, N, W, T, Z, IERR) RETURN END SUBROUTINE TRED1(NM,N,A,D,E,E2) C INTEGER I,J,K,L,N,II,NM,JP1 REAL A(NM,N),D(N),E(N),E2(N) REAL F,G,H,SCALE C REAL SQRT,ABS C----------------------------------------------------------------------- C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED1, C NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). C C THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX C TO A SYMMETRIC TRIDIAGONAL MATRIX USING C ORTHOGONAL SIMILARITY TRANSFORMATIONS. C C ON INPUT- C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C N IS THE ORDER OF THE MATRIX, C C A CONTAINS THE REAL SYMMETRIC INPUT MATRIX. ONLY THE C LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED. C C ON OUTPUT- C C A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS- C FORMATIONS USED IN THE REDUCTION IN ITS STRICT LOWER C TRIANGLE. THE FULL UPPER TRIANGLE OF A IS UNALTERED, C C D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX, C C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO, C C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. C E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. C C----------------------------------------------------------------------- C DO 100 I = 1, N 100 D(I) = A(I,I) C ********** FOR I=N STEP -1 UNTIL 1 DO -- ********** DO 300 II = 1, N I = N + 1 - II L = I - 1 H = 0.0 SCALE = 0.0 IF (L .LT. 1) GO TO 130 C ********** SCALE ROW (ALGOL TOL THEN NOT NEEDED) ********** DO 120 K = 1, L 120 SCALE = SCALE + ABS(A(I,K)) C IF (SCALE .NE. 0.0) GO TO 140 130 E(I) = 0.0 E2(I) = 0.0 GO TO 290 C 140 DO 150 K = 1, L A(I,K) = A(I,K) / SCALE H = H + A(I,K) * A(I,K) 150 CONTINUE C E2(I) = SCALE * SCALE * H F = A(I,L) G = SQRT(H) IF (F .GE. 0.0) G = -G E(I) = SCALE * G H = H - F * G A(I,L) = F - G IF (L .EQ. 1) GO TO 270 F = 0.0 C DO 240 J = 1, L G = 0.0 C ********** FORM ELEMENT OF A*U ********** DO 180 K = 1, J 180 G = G + A(J,K) * A(I,K) C JP1 = J + 1 IF (L .LT. JP1) GO TO 220 C DO 200 K = JP1, L 200 G = G + A(K,J) * A(I,K) C ********** FORM ELEMENT OF P ********** 220 E(J) = G / H F = F + E(J) * A(I,J) 240 CONTINUE C H = F / (H + H) C ********** FORM REDUCED A ********** DO 260 J = 1, L F = A(I,J) G = E(J) - H * F E(J) = G C DO 260 K = 1, J A(J,K) = A(J,K) - F * E(K) - G * A(I,K) 260 CONTINUE C 270 DO 280 K = 1, L 280 A(I,K) = SCALE * A(I,K) C 290 H = D(I) D(I) = A(I,I) A(I,I) = H 300 CONTINUE C RETURN C ********** LAST CARD OF TRED1 ********** END SUBROUTINE TRED3(N,NV,A,D,E,E2) C INTEGER I,J,K,L,N,II,IZ,JK,NV REAL A(NV),D(N),E(N),E2(N) REAL F,G,H,HH,SCALE C REAL SQRT,ABS C----------------------------------------------------------------------- C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED3, C NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). C C THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX, STORED AS C A ONE-DIMENSIONAL ARRAY, TO A SYMMETRIC TRIDIAGONAL MATRIX C USING ORTHOGONAL SIMILARITY TRANSFORMATIONS. C C ON INPUT- C C N IS THE ORDER OF THE MATRIX, C C NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER A C AS DECLARED IN THE CALLING PROGRAM DIMENSION STATEMENT, C C A CONTAINS THE LOWER TRIANGLE OF THE REAL SYMMETRIC C INPUT MATRIX, STORED ROW-WISE AS A ONE-DIMENSIONAL C ARRAY, IN ITS FIRST N*(N+1)/2 POSITIONS. C C ON OUTPUT- C C A CONTAINS INFORMATION ABOUT THE ORTHOGONAL C TRANSFORMATIONS USED IN THE REDUCTION, C C D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX, C C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO, C C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. C E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. C C----------------------------------------------------------------------- C C ********** FOR I=N STEP -1 UNTIL 1 DO -- ********** DO 300 II = 1, N I = N + 1 - II L = I - 1 IZ = (I * L) / 2 H = 0.0 SCALE = 0.0 IF (L .LT. 1) GO TO 130 C ********** SCALE ROW (ALGOL TOL THEN NOT NEEDED) ********** DO 120 K = 1, L IZ = IZ + 1 D(K) = A(IZ) SCALE = SCALE + ABS(D(K)) 120 CONTINUE C IF (SCALE .NE. 0.0) GO TO 140 130 E(I) = 0.0 E2(I) = 0.0 GO TO 290 C 140 DO 150 K = 1, L D(K) = D(K) / SCALE H = H + D(K) * D(K) 150 CONTINUE C E2(I) = SCALE * SCALE * H F = D(L) G = SQRT(H) IF (F .GE. 0.0) G = -G E(I) = SCALE * G H = H - F * G D(L) = F - G A(IZ) = SCALE * D(L) IF (L .EQ. 1) GO TO 290 F = 0.0 C DO 240 J = 1, L G = 0.0 JK = (J * (J-1)) / 2 C ********** FORM ELEMENT OF A*U ********** DO 180 K = 1, L JK = JK + 1 IF (K .GT. J) JK = JK + K - 2 G = G + A(JK) * D(K) 180 CONTINUE C ********** FORM ELEMENT OF P ********** E(J) = G / H F = F + E(J) * D(J) 240 CONTINUE C HH = F / (H + H) JK = 0 C ********** FORM REDUCED A ********** DO 260 J = 1, L F = D(J) G = E(J) - HH * F E(J) = G C DO 260 K = 1, J JK = JK + 1 A(JK) = A(JK) - F * E(K) - G * D(K) 260 CONTINUE C 290 D(I) = A(IZ+1) A(IZ+1) = SCALE * SQRT(H) 300 CONTINUE C RETURN C ********** LAST CARD OF TRED3 ********** END SUBROUTINE TQLRAT(N,D,E2,IERR) C INTEGER I,J,L,M,N,II,L1,MML,IERR REAL D(N),E2(N) REAL B,C,F,G,H,P,R,S,MACHEP C REAL SQRT,ABS,SPMPAR C----------------------------------------------------------------------- C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQLRAT, C ALGORITHM 464, COMM. ACM 16, 689(1973) BY REINSCH. C C THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC C TRIDIAGONAL MATRIX BY THE RATIONAL QL METHOD. C C ON INPUT- C C N IS THE ORDER OF THE MATRIX, C C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX, C C E2 CONTAINS THE SQUARES OF THE SUBDIAGONAL ELEMENTS OF THE C INPUT MATRIX IN ITS LAST N-1 POSITIONS. E2(1) IS ARBITRARY. C C ON OUTPUT- C C D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND C ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE C THE SMALLEST EIGENVALUES, C C E2 HAS BEEN DESTROYED, C C IERR IS SET TO C ZERO FOR NORMAL RETURN, C J IF THE J-TH EIGENVALUE HAS NOT BEEN C DETERMINED AFTER 30 ITERATIONS. C C----------------------------------------------------------------------- C C ********** MACHEP IS A MACHINE DEPENDENT PARAMETER. ASSIGN C MACHEP THE VALUE U WHERE U IS THE SMALLEST POSITIVE C FLOATING POINT NUMBER SUCH THAT 1.0 + U .GT. 1.0 . C MACHEP = SPMPAR(1) C C ********** C IERR = 0 IF (N .EQ. 1) GO TO 1001 C DO 100 I = 2, N 100 E2(I-1) = E2(I) C F = 0.0 B = 0.0 E2(N) = 0.0 C DO 290 L = 1, N J = 0 H = MACHEP * (ABS(D(L)) + SQRT(E2(L))) IF (B .GT. H) GO TO 105 B = H C = B * B C ********** LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT ********** 105 DO 110 M = L, N IF (E2(M) .LE. C) GO TO 120 C ********** E2(N) IS ALWAYS ZERO, SO THERE IS NO EXIT C THROUGH THE BOTTOM OF THE LOOP ********** 110 CONTINUE C 120 IF (M .EQ. L) GO TO 210 130 IF (J .EQ. 30) GO TO 1000 J = J + 1 C ********** FORM SHIFT ********** L1 = L + 1 S = SQRT(E2(L)) G = D(L) P = (D(L1) - G) / (2.0 * S) R = SQRT(P*P+1.0) IF (P .LT. 0.0) R = -R D(L) = S / (P + R) H = G - D(L) C DO 140 I = L1, N 140 D(I) = D(I) - H C F = F + H C ********** RATIONAL QL TRANSFORMATION ********** G = D(M) IF (G .EQ. 0.0) G = B H = G S = 0.0 MML = M - L C ********** FOR I=M-1 STEP -1 UNTIL L DO -- ********** DO 200 II = 1, MML I = M - II P = G * H R = P + E2(I) E2(I+1) = S * R S = E2(I) / R D(I+1) = H + S * (H + D(I)) G = D(I) - E2(I) / G IF (G .EQ. 0.0) G = B H = G * P / R 200 CONTINUE C E2(L) = S * G D(L) = H C ********** GUARD AGAINST UNDERFLOW IN CONVERGENCE TEST ********** IF (H .EQ. 0.0) GO TO 210 IF (ABS(E2(L)) .LE. ABS(C/H)) GO TO 210 E2(L) = H * E2(L) IF (E2(L) .NE. 0.0) GO TO 130 210 P = D(L) + F C ********** ORDER EIGENVALUES ********** IF (L .EQ. 1) GO TO 250 C ********** FOR I=L STEP -1 UNTIL 2 DO -- ********** DO 230 II = 2, L I = L + 2 - II IF (P .GE. D(I-1)) GO TO 270 D(I) = D(I-1) 230 CONTINUE C 250 I = 1 270 D(I) = P 290 CONTINUE C GO TO 1001 C ********** SET ERROR -- NO CONVERGENCE TO AN C EIGENVALUE AFTER 30 ITERATIONS ********** 1000 IERR = L 1001 RETURN C ********** LAST CARD OF TQLRAT ********** END SUBROUTINE IMTQL1(N,D,E,IERR) C INTEGER I,J,L,M,N,II,MML,IERR REAL D(N),E(N) REAL B,C,F,G,P,R,S,MACHEP C REAL SQRT,ABS,SPMPAR C----------------------------------------------------------------------- C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE IMTQL1, C NUM. MATH. 12, 377-383(1968) BY MARTIN AND WILKINSON, C AS MODIFIED IN NUM. MATH. 15, 450(1970) BY DUBRULLE. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971). C C THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC C TRIDIAGONAL MATRIX BY THE IMPLICIT QL METHOD. C C ON INPUT- C C N IS THE ORDER OF THE MATRIX, C C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX, C C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY. C C ON OUTPUT- C C D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND C ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE C THE SMALLEST EIGENVALUES, C C E HAS BEEN DESTROYED, C C IERR IS SET TO C ZERO FOR NORMAL RETURN, C J IF THE J-TH EIGENVALUE HAS NOT BEEN C DETERMINED AFTER 30 ITERATIONS. C C----------------------------------------------------------------------- C C ********** MACHEP IS A MACHINE DEPENDENT PARAMETER. ASSIGN C MACHEP THE VALUE U WHERE U IS THE SMALLEST POSITIVE C FLOATING POINT NUMBER SUCH THAT 1.0 + U .GT. 1.0 . C MACHEP = SPMPAR(1) C C ********** C IERR = 0 IF (N .EQ. 1) GO TO 1001 C DO 100 I = 2, N 100 E(I-1) = E(I) C E(N) = 0.0 C DO 290 L = 1, N J = 0 C ********** LOOK FOR SMALL SUB-DIAGONAL ELEMENT ********** 105 DO 110 M = L, N IF (M .EQ. N) GO TO 120 IF (ABS(E(M)) .LE. MACHEP * (ABS(D(M)) + ABS(D(M+1)))) X GO TO 120 110 CONTINUE C 120 P = D(L) IF (M .EQ. L) GO TO 215 IF (J .EQ. 30) GO TO 1000 J = J + 1 C ********** FORM SHIFT ********** G = (D(L+1) - P) / (2.0 * E(L)) R = SQRT(G*G+1.0) IF (G .LT. 0.0) R = -R G = D(M) - P + E(L) / (G + R) S = 1.0 C = 1.0 P = 0.0 MML = M - L C ********** FOR I=M-1 STEP -1 UNTIL L DO -- ********** DO 200 II = 1, MML I = M - II F = S * E(I) B = C * E(I) IF (ABS(F) .LT. ABS(G)) GO TO 150 C = G / F R = SQRT(C*C+1.0) E(I+1) = F * R S = 1.0 / R C = C * S GO TO 160 150 S = F / G R = SQRT(S*S+1.0) E(I+1) = G * R C = 1.0 / R S = S * C 160 G = D(I+1) - P R = (D(I) - G) * S + 2.0 * C * B P = S * R D(I+1) = G + P G = C * R - B 200 CONTINUE C D(L) = D(L) - P E(L) = G E(M) = 0.0 GO TO 105 C ********** ORDER EIGENVALUES ********** 215 IF (L .EQ. 1) GO TO 250 C ********** FOR I=L STEP -1 UNTIL 2 DO -- ********** DO 230 II = 2, L I = L + 2 - II IF (P .GE. D(I-1)) GO TO 270 D(I) = D(I-1) 230 CONTINUE C 250 I = 1 270 D(I) = P 290 CONTINUE C GO TO 1001 C ********** SET ERROR -- NO CONVERGENCE TO AN C EIGENVALUE AFTER 30 ITERATIONS ********** 1000 IERR = L 1001 RETURN C ********** LAST CARD OF IMTQL1 ********** END SUBROUTINE TRED2(NM,N,A,D,E,Z) C INTEGER I,J,K,L,N,II,NM,JP1 REAL A(NM,N),D(N),E(N),Z(NM,N) REAL F,G,H,HH,SCALE C REAL SQRT,ABS C----------------------------------------------------------------------- C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED2, C NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). C C THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX TO A C SYMMETRIC TRIDIAGONAL MATRIX USING AND ACCUMULATING C ORTHOGONAL SIMILARITY TRANSFORMATIONS. C C ON INPUT- C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C N IS THE ORDER OF THE MATRIX, C C A CONTAINS THE REAL SYMMETRIC INPUT MATRIX. ONLY THE C LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED. C C ON OUTPUT- C C D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX, C C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO, C C Z CONTAINS THE ORTHOGONAL TRANSFORMATION MATRIX C PRODUCED IN THE REDUCTION, C C A AND Z MAY COINCIDE. IF DISTINCT, A IS UNALTERED. C C----------------------------------------------------------------------- C DO 100 I = 1, N C DO 100 J = 1, I Z(I,J) = A(I,J) 100 CONTINUE C IF (N .EQ. 1) GO TO 320 C ********** FOR I=N STEP -1 UNTIL 2 DO -- ********** DO 300 II = 2, N I = N + 2 - II L = I - 1 H = 0.0 SCALE = 0.0 IF (L .LT. 2) GO TO 130 C ********** SCALE ROW (ALGOL TOL THEN NOT NEEDED) ********** DO 120 K = 1, L 120 SCALE = SCALE + ABS(Z(I,K)) C IF (SCALE .NE. 0.0) GO TO 140 130 E(I) = Z(I,L) GO TO 290 C 140 DO 150 K = 1, L Z(I,K) = Z(I,K) / SCALE H = H + Z(I,K) * Z(I,K) 150 CONTINUE C F = Z(I,L) G = SQRT(H) IF (F .GE. 0.0) G = -G E(I) = SCALE * G H = H - F * G Z(I,L) = F - G F = 0.0 C DO 240 J = 1, L Z(J,I) = Z(I,J) / H G = 0.0 C ********** FORM ELEMENT OF A*U ********** DO 180 K = 1, J 180 G = G + Z(J,K) * Z(I,K) C JP1 = J + 1 IF (L .LT. JP1) GO TO 220 C DO 200 K = JP1, L 200 G = G + Z(K,J) * Z(I,K) C ********** FORM ELEMENT OF P ********** 220 E(J) = G / H F = F + E(J) * Z(I,J) 240 CONTINUE C HH = F / (H + H) C ********** FORM REDUCED A ********** DO 260 J = 1, L F = Z(I,J) G = E(J) - HH * F E(J) = G C DO 260 K = 1, J Z(J,K) = Z(J,K) - F * E(K) - G * Z(I,K) 260 CONTINUE C 290 D(I) = H 300 CONTINUE C 320 D(1) = 0.0 E(1) = 0.0 C ********** ACCUMULATION OF TRANSFORMATION MATRICES ********** DO 500 I = 1, N L = I - 1 IF (D(I) .EQ. 0.0) GO TO 380 C DO 360 J = 1, L G = 0.0 C DO 340 K = 1, L 340 G = G + Z(I,K) * Z(K,J) C DO 360 K = 1, L Z(K,J) = Z(K,J) - G * Z(K,I) 360 CONTINUE C 380 D(I) = Z(I,I) Z(I,I) = 1.0 IF (L .LT. 1) GO TO 500 C DO 400 J = 1, L Z(I,J) = 0.0 Z(J,I) = 0.0 400 CONTINUE C 500 CONTINUE C RETURN C ********** LAST CARD OF TRED2 ********** END SUBROUTINE TQL2(NM,N,D,E,Z,IERR) C INTEGER I,J,K,L,M,N,II,L1,NM,MML,IERR REAL D(N),E(N),Z(NM,N) REAL B,C,F,G,H,P,R,S,MACHEP C REAL SQRT,ABS,SPMPAR C----------------------------------------------------------------------- C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQL2, C NUM. MATH. 11, 293-306(1968) BY BOWDLER, MARTIN, REINSCH, AND C WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971). C C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS C OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE QL METHOD. C THE EIGENVECTORS OF A FULL SYMMETRIC MATRIX CAN ALSO C BE FOUND IF TRED2 HAS BEEN USED TO REDUCE THIS C FULL MATRIX TO TRIDIAGONAL FORM. C C ON INPUT- C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C N IS THE ORDER OF THE MATRIX, C C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX, C C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY, C C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE C REDUCTION BY TRED2, IF PERFORMED. IF THE EIGENVECTORS C OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN C THE IDENTITY MATRIX. C C ON OUTPUT- C C D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT C UNORDERED FOR INDICES 1,2,...,IERR-1, C C E HAS BEEN DESTROYED, C C Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC C TRIDIAGONAL (OR FULL) MATRIX. IF AN ERROR EXIT IS MADE, C Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED C EIGENVALUES, C C IERR IS SET TO C ZERO FOR NORMAL RETURN, C J IF THE J-TH EIGENVALUE HAS NOT BEEN C DETERMINED AFTER 30 ITERATIONS. C C----------------------------------------------------------------------- C C ********** MACHEP IS A MACHINE DEPENDENT PARAMETER. ASSIGN C MACHEP THE VALUE U WHERE U IS THE SMALLEST POSITIVE C FLOATING POINT NUMBER SUCH THAT 1.0 + U .GT. 1.0 . C MACHEP = SPMPAR(1) C C ********** C IERR = 0 IF (N .EQ. 1) GO TO 1001 C DO 100 I = 2, N 100 E(I-1) = E(I) C F = 0.0 B = 0.0 E(N) = 0.0 C DO 240 L = 1, N J = 0 H = MACHEP * (ABS(D(L)) + ABS(E(L))) IF (B .LT. H) B = H C ********** LOOK FOR SMALL SUB-DIAGONAL ELEMENT ********** DO 110 M = L, N IF (ABS(E(M)) .LE. B) GO TO 120 C ********** E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT C THROUGH THE BOTTOM OF THE LOOP ********** 110 CONTINUE C 120 IF (M .EQ. L) GO TO 220 130 IF (J .EQ. 30) GO TO 1000 J = J + 1 C ********** FORM SHIFT ********** L1 = L + 1 G = D(L) P = (D(L1) - G) / (2.0 * E(L)) R = SQRT(P*P+1.0) IF (P .LT. 0.0) R = -R D(L) = E(L) / (P + R) H = G - D(L) C DO 140 I = L1, N 140 D(I) = D(I) - H C F = F + H C ********** QL TRANSFORMATION ********** P = D(M) C = 1.0 S = 0.0 MML = M - L C ********** FOR I=M-1 STEP -1 UNTIL L DO -- ********** DO 200 II = 1, MML I = M - II G = C * E(I) H = C * P IF (ABS(P) .LT. ABS(E(I))) GO TO 150 C = E(I) / P R = SQRT(C*C+1.0) E(I+1) = S * P * R S = C / R C = 1.0 / R GO TO 160 150 C = P / E(I) R = SQRT(C*C+1.0) E(I+1) = S * E(I) * R S = 1.0 / R C = C * S 160 P = C * D(I) - S * G D(I+1) = H + S * (C * G + S * D(I)) C ********** FORM VECTOR ********** DO 180 K = 1, N H = Z(K,I+1) Z(K,I+1) = S * Z(K,I) + C * H Z(K,I) = C * Z(K,I) - S * H 180 CONTINUE C 200 CONTINUE C E(L) = S * P D(L) = C * P IF (ABS(E(L)) .GT. B) GO TO 130 220 D(L) = D(L) + F 240 CONTINUE C ********** ORDER EIGENVALUES AND EIGENVECTORS ********** DO 300 II = 2, N I = II - 1 K = I P = D(I) C DO 260 J = II, N IF (D(J) .GE. P) GO TO 260 K = J P = D(J) 260 CONTINUE C IF (K .EQ. I) GO TO 300 D(K) = D(I) D(I) = P C DO 280 J = 1, N P = Z(J,I) Z(J,I) = Z(J,K) Z(J,K) = P 280 CONTINUE C 300 CONTINUE C GO TO 1001 C ********** SET ERROR -- NO CONVERGENCE TO AN C EIGENVALUE AFTER 30 ITERATIONS ********** 1000 IERR = L 1001 RETURN C ********** LAST CARD OF TQL2 ********** END SUBROUTINE IMTQL2(NM,N,D,E,Z,IERR) C INTEGER I,J,K,L,M,N,II,NM,MML,IERR REAL D(N),E(N),Z(NM,N) REAL B,C,F,G,P,R,S,MACHEP C REAL SQRT,ABS,SPMPAR C----------------------------------------------------------------------- C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE IMTQL2, C NUM. MATH. 12, 377-383(1968) BY MARTIN AND WILKINSON, C AS MODIFIED IN NUM. MATH. 15, 450(1970) BY DUBRULLE. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971). C C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS C OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE IMPLICIT QL METHOD. C THE EIGENVECTORS OF A FULL SYMMETRIC MATRIX CAN ALSO C BE FOUND IF TRED2 HAS BEEN USED TO REDUCE THIS C FULL MATRIX TO TRIDIAGONAL FORM. C C ON INPUT- C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C N IS THE ORDER OF THE MATRIX, C C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX, C C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY, C C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE C REDUCTION BY TRED2, IF PERFORMED. IF THE EIGENVECTORS C OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN C THE IDENTITY MATRIX. C C ON OUTPUT- C C D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT C UNORDERED FOR INDICES 1,2,...,IERR-1, C C E HAS BEEN DESTROYED, C C Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC C TRIDIAGONAL (OR FULL) MATRIX. IF AN ERROR EXIT IS MADE, C Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED C EIGENVALUES, C C IERR IS SET TO C ZERO FOR NORMAL RETURN, C J IF THE J-TH EIGENVALUE HAS NOT BEEN C DETERMINED AFTER 30 ITERATIONS. C C----------------------------------------------------------------------- C C ********** MACHEP IS A MACHINE DEPENDENT PARAMETER. ASSIGN C MACHEP THE VALUE U WHERE U IS THE SMALLEST POSITIVE C FLOATING POINT NUMBER SUCH THAT 1.0 + U .GT. 1.0 . C MACHEP = SPMPAR(1) C C ********** C IERR = 0 IF (N .EQ. 1) GO TO 1001 C DO 100 I = 2, N 100 E(I-1) = E(I) C E(N) = 0.0 C DO 240 L = 1, N J = 0 C ********** LOOK FOR SMALL SUB-DIAGONAL ELEMENT ********** 105 DO 110 M = L, N IF (M .EQ. N) GO TO 120 IF (ABS(E(M)) .LE. MACHEP * (ABS(D(M)) + ABS(D(M+1)))) X GO TO 120 110 CONTINUE C 120 P = D(L) IF (M .EQ. L) GO TO 240 IF (J .EQ. 30) GO TO 1000 J = J + 1 C ********** FORM SHIFT ********** G = (D(L+1) - P) / (2.0 * E(L)) R = SQRT(G*G+1.0) IF (G .LT. 0.0) R = -R G = D(M) - P + E(L) / (G + R) S = 1.0 C = 1.0 P = 0.0 MML = M - L C ********** FOR I=M-1 STEP -1 UNTIL L DO -- ********** DO 200 II = 1, MML I = M - II F = S * E(I) B = C * E(I) IF (ABS(F) .LT. ABS(G)) GO TO 150 C = G / F R = SQRT(C*C+1.0) E(I+1) = F * R S = 1.0 / R C = C * S GO TO 160 150 S = F / G R = SQRT(S*S+1.0) E(I+1) = G * R C = 1.0 / R S = S * C 160 G = D(I+1) - P R = (D(I) - G) * S + 2.0 * C * B P = S * R D(I+1) = G + P G = C * R - B C ********** FORM VECTOR ********** DO 180 K = 1, N F = Z(K,I+1) Z(K,I+1) = S * Z(K,I) + C * F Z(K,I) = C * Z(K,I) - S * F 180 CONTINUE C 200 CONTINUE C D(L) = D(L) - P E(L) = G E(M) = 0.0 GO TO 105 240 CONTINUE C ********** ORDER EIGENVALUES AND EIGENVECTORS ********** DO 300 II = 2, N I = II - 1 K = I P = D(I) C DO 260 J = II, N IF (D(J) .GE. P) GO TO 260 K = J P = D(J) 260 CONTINUE C IF (K .EQ. I) GO TO 300 D(K) = D(I) D(I) = P C DO 280 J = 1, N P = Z(J,I) Z(J,I) = Z(J,K) Z(J,K) = P 280 CONTINUE C 300 CONTINUE C GO TO 1001 C ********** SET ERROR -- NO CONVERGENCE TO AN C EIGENVALUE AFTER 30 ITERATIONS ********** 1000 IERR = L 1001 RETURN C ********** LAST CARD OF IMTQL2 ********** END SUBROUTINE DSEIG (A, KA, N, W, T, IERR) C----------------------------------------------------------------------- C DOUBLE PRECISION COMPUTATION OF THE C EIGENVALUES OF SYMMETRIC REAL MATRICES C----------------------------------------------------------------------- DOUBLE PRECISION A(*), W(N), T(*) C IF (KA .EQ. 0) GO TO 10 CALL DTRED1 (KA, N, A, W, T(N+1), T(1)) CALL DTQL (N, W, T, IERR) RETURN 10 L = N*(N + 1) L = L/2 CALL DTRED3 (N, L, A, W, T(N+1), T(1)) CALL DTQL (N, W, T, IERR) RETURN END SUBROUTINE DSEIGV (A, KA, N, W, Z, T, IERR) C----------------------------------------------------------------------- C DOUBLE PRECISION COMPUTATION OF C EIGENVALUES AND EIGENVECTORS OF C SYMMETRIC REAL MATRICES C----------------------------------------------------------------------- DOUBLE PRECISION A(KA,N), W(N), Z(KA,N), T(N) C CALL DTRED2 (KA, N, A, W, T, Z) CALL DTQL2 (KA, N, W, T, Z, IERR) RETURN END SUBROUTINE DTRED1 (NM,N,A,D,E,E2) C INTEGER I,J,K,L,N,II,NM,JP1 DOUBLE PRECISION A(NM,N),D(N),E(N),E2(N) DOUBLE PRECISION F,G,H,SCALE C DOUBLE PRECISION DSQRT,DABS C----------------------------------------------------------------------- C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED1, C NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). C C THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX C TO A SYMMETRIC TRIDIAGONAL MATRIX USING C ORTHOGONAL SIMILARITY TRANSFORMATIONS. C C ON INPUT- C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C N IS THE ORDER OF THE MATRIX, C C A CONTAINS THE REAL SYMMETRIC INPUT MATRIX. ONLY THE C LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED. C C ON OUTPUT- C C A CONTAINS INFORMATION ABOUT THE ORTHOGONAL TRANS- C FORMATIONS USED IN THE REDUCTION IN ITS STRICT LOWER C TRIANGLE. THE FULL UPPER TRIANGLE OF A IS UNALTERED, C C D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX, C C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO, C C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. C E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. C C----------------------------------------------------------------------- C DO 100 I = 1, N 100 D(I) = A(I,I) C ********** FOR I=N STEP -1 UNTIL 1 DO -- ********** DO 300 II = 1, N I = N + 1 - II L = I - 1 H = 0.D0 SCALE = 0.D0 IF (L .LT. 1) GO TO 130 C ********** SCALE ROW (ALGOL TOL THEN NOT NEEDED) ********** DO 120 K = 1, L 120 SCALE = SCALE + DABS(A(I,K)) C IF (SCALE .NE. 0.D0) GO TO 140 130 E(I) = 0.D0 E2(I) = 0.D0 GO TO 290 C 140 DO 150 K = 1, L A(I,K) = A(I,K) / SCALE H = H + A(I,K) * A(I,K) 150 CONTINUE C E2(I) = SCALE * SCALE * H F = A(I,L) G = DSQRT(H) IF (F .GE. 0.D0) G = -G E(I) = SCALE * G H = H - F * G A(I,L) = F - G IF (L .EQ. 1) GO TO 270 F = 0.D0 C DO 240 J = 1, L G = 0.D0 C ********** FORM ELEMENT OF A*U ********** DO 180 K = 1, J 180 G = G + A(J,K) * A(I,K) C JP1 = J + 1 IF (L .LT. JP1) GO TO 220 C DO 200 K = JP1, L 200 G = G + A(K,J) * A(I,K) C ********** FORM ELEMENT OF P ********** 220 E(J) = G / H F = F + E(J) * A(I,J) 240 CONTINUE C H = F / (H + H) C ********** FORM REDUCED A ********** DO 260 J = 1, L F = A(I,J) G = E(J) - H * F E(J) = G C DO 260 K = 1, J A(J,K) = A(J,K) - F * E(K) - G * A(I,K) 260 CONTINUE C 270 DO 280 K = 1, L 280 A(I,K) = SCALE * A(I,K) C 290 H = D(I) D(I) = A(I,I) A(I,I) = H 300 CONTINUE C RETURN C ********** LAST CARD OF DTRED1 ********** END SUBROUTINE DTRED3 (N,NV,A,D,E,E2) C INTEGER I,J,K,L,N,II,IZ,JK,NV DOUBLE PRECISION A(NV),D(N),E(N),E2(N) DOUBLE PRECISION F,G,H,HH,SCALE C DOUBLE PRECISION DSQRT,DABS C----------------------------------------------------------------------- C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED3, C NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). C C THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX, STORED AS C A ONE-DIMENSIONAL ARRAY, TO A SYMMETRIC TRIDIAGONAL MATRIX C USING ORTHOGONAL SIMILARITY TRANSFORMATIONS. C C ON INPUT- C C N IS THE ORDER OF THE MATRIX, C C NV MUST BE SET TO THE DIMENSION OF THE ARRAY PARAMETER A C AS DECLARED IN THE CALLING PROGRAM DIMENSION STATEMENT, C C A CONTAINS THE LOWER TRIANGLE OF THE REAL SYMMETRIC C INPUT MATRIX, STORED ROW-WISE AS A ONE-DIMENSIONAL C ARRAY, IN ITS FIRST N*(N+1)/2 POSITIONS. C C ON OUTPUT- C C A CONTAINS INFORMATION ABOUT THE ORTHOGONAL C TRANSFORMATIONS USED IN THE REDUCTION, C C D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX, C C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO, C C E2 CONTAINS THE SQUARES OF THE CORRESPONDING ELEMENTS OF E. C E2 MAY COINCIDE WITH E IF THE SQUARES ARE NOT NEEDED. C C----------------------------------------------------------------------- C C ********** FOR I=N STEP -1 UNTIL 1 DO -- ********** DO 300 II = 1, N I = N + 1 - II L = I - 1 IZ = (I * L) / 2 H = 0.D0 SCALE = 0.D0 IF (L .LT. 1) GO TO 130 C ********** SCALE ROW (ALGOL TOL THEN NOT NEEDED) ********** DO 120 K = 1, L IZ = IZ + 1 D(K) = A(IZ) SCALE = SCALE + DABS(D(K)) 120 CONTINUE C IF (SCALE .NE. 0.D0) GO TO 140 130 E(I) = 0.D0 E2(I) = 0.D0 GO TO 290 C 140 DO 150 K = 1, L D(K) = D(K) / SCALE H = H + D(K) * D(K) 150 CONTINUE C E2(I) = SCALE * SCALE * H F = D(L) G = DSQRT(H) IF (F .GE. 0.D0) G = -G E(I) = SCALE * G H = H - F * G D(L) = F - G A(IZ) = SCALE * D(L) IF (L .EQ. 1) GO TO 290 F = 0.D0 C DO 240 J = 1, L G = 0.D0 JK = (J * (J-1)) / 2 C ********** FORM ELEMENT OF A*U ********** DO 180 K = 1, L JK = JK + 1 IF (K .GT. J) JK = JK + K - 2 G = G + A(JK) * D(K) 180 CONTINUE C ********** FORM ELEMENT OF P ********** E(J) = G / H F = F + E(J) * D(J) 240 CONTINUE C HH = F / (H + H) JK = 0 C ********** FORM REDUCED A ********** DO 260 J = 1, L F = D(J) G = E(J) - HH * F E(J) = G C DO 260 K = 1, J JK = JK + 1 A(JK) = A(JK) - F * E(K) - G * D(K) 260 CONTINUE C 290 D(I) = A(IZ+1) A(IZ+1) = SCALE * DSQRT(H) 300 CONTINUE C RETURN C ********** LAST CARD OF DTRED3 ********** END SUBROUTINE DTQL (N,D,E2,IERR) C INTEGER I,J,L,M,N,II,L1,MML,IERR DOUBLE PRECISION D(N),E2(N) DOUBLE PRECISION B,C,F,G,H,P,R,S,MACHEP DOUBLE PRECISION DPMPAR C----------------------------------------------------------------------- C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQLRAT, C ALGORITHM 464, COMM. ACM 16, 689(1973) BY REINSCH. C C THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC C TRIDIAGONAL MATRIX BY THE RATIONAL QL METHOD. C C ON INPUT- C C N IS THE ORDER OF THE MATRIX, C C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX, C C E2 CONTAINS THE SQUARES OF THE SUBDIAGONAL ELEMENTS OF THE C INPUT MATRIX IN ITS LAST N-1 POSITIONS. E2(1) IS ARBITRARY. C C ON OUTPUT- C C D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND C ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE C THE SMALLEST EIGENVALUES, C C E2 HAS BEEN DESTROYED, C C IERR IS SET TO C ZERO FOR NORMAL RETURN, C J IF THE J-TH EIGENVALUE HAS NOT BEEN C DETERMINED AFTER 50 ITERATIONS. C C----------------------------------------------------------------------- C C ********** MACHEP IS A MACHINE DEPENDENT PARAMETER. ASSIGN C MACHEP THE VALUE U WHERE U IS THE SMALLEST POSITIVE C FLOATING POINT NUMBER SUCH THAT 1.0 + U .GT. 1.0 . C MACHEP = DPMPAR(1) C C ********** C IERR = 0 IF (N .EQ. 1) GO TO 1001 C DO 100 I = 2, N 100 E2(I-1) = E2(I) C F = 0.D0 B = 0.D0 E2(N) = 0.D0 C DO 290 L = 1, N J = 0 H = MACHEP * (DABS(D(L)) + DSQRT(E2(L))) IF (B .GT. H) GO TO 105 B = H C = B * B C ********** LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT ********** 105 DO 110 M = L, N IF (E2(M) .LE. C) GO TO 120 C ********** E2(N) IS ALWAYS ZERO, SO THERE IS NO EXIT C THROUGH THE BOTTOM OF THE LOOP ********** 110 CONTINUE C 120 IF (M .EQ. L) GO TO 210 130 IF (J .EQ. 50) GO TO 1000 J = J + 1 C ********** FORM SHIFT ********** L1 = L + 1 S = DSQRT(E2(L)) G = D(L) P = (D(L1) - G) / (2.D0 * S) R = DSQRT(P*P + 1.D0) IF (P .LT. 0.D0) R = -R D(L) = S / (P + R) H = G - D(L) C DO 140 I = L1, N 140 D(I) = D(I) - H C F = F + H C ********** RATIONAL QL TRANSFORMATION ********** G = D(M) IF (G .EQ. 0.D0) G = B H = G S = 0.D0 MML = M - L C ********** FOR I=M-1 STEP -1 UNTIL L DO -- ********** DO 200 II = 1, MML I = M - II P = G * H R = P + E2(I) E2(I+1) = S * R S = E2(I) / R D(I+1) = H + S * (H + D(I)) G = D(I) - E2(I) / G IF (G .EQ. 0.D0) G = B H = G * P / R 200 CONTINUE C E2(L) = S * G D(L) = H C ********** GUARD AGAINST UNDERFLOW IN CONVERGENCE TEST ********** IF (H .EQ. 0.D0) GO TO 210 IF (DABS(E2(L)) .LE. DABS(C/H)) GO TO 210 E2(L) = H * E2(L) IF (E2(L) .NE. 0.D0) GO TO 130 210 P = D(L) + F C ********** ORDER EIGENVALUES ********** IF (L .EQ. 1) GO TO 250 C ********** FOR I=L STEP -1 UNTIL 2 DO -- ********** DO 230 II = 2, L I = L + 2 - II IF (P .GE. D(I-1)) GO TO 270 D(I) = D(I-1) 230 CONTINUE C 250 I = 1 270 D(I) = P 290 CONTINUE C GO TO 1001 C ********** SET ERROR -- NO CONVERGENCE TO AN C EIGENVALUE AFTER 50 ITERATIONS ********** 1000 IERR = L 1001 RETURN C ********** LAST CARD OF DTQL ********** END SUBROUTINE DTRED2 (NM,N,A,D,E,Z) C INTEGER I,J,K,L,N,II,NM,JP1 DOUBLE PRECISION A(NM,N),D(N),E(N),Z(NM,N) DOUBLE PRECISION F,G,H,HH,SCALE C DOUBLE PRECISION DSQRT,DABS C----------------------------------------------------------------------- C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TRED2, C NUM. MATH. 11, 181-195(1968) BY MARTIN, REINSCH, AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 212-226(1971). C C THIS SUBROUTINE REDUCES A REAL SYMMETRIC MATRIX TO A C SYMMETRIC TRIDIAGONAL MATRIX USING AND ACCUMULATING C ORTHOGONAL SIMILARITY TRANSFORMATIONS. C C ON INPUT- C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C N IS THE ORDER OF THE MATRIX, C C A CONTAINS THE REAL SYMMETRIC INPUT MATRIX. ONLY THE C LOWER TRIANGLE OF THE MATRIX NEED BE SUPPLIED. C C ON OUTPUT- C C D CONTAINS THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX, C C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL C MATRIX IN ITS LAST N-1 POSITIONS. E(1) IS SET TO ZERO, C C Z CONTAINS THE ORTHOGONAL TRANSFORMATION MATRIX C PRODUCED IN THE REDUCTION, C C A AND Z MAY COINCIDE. IF DISTINCT, A IS UNALTERED. C C----------------------------------------------------------------------- C DO 100 I = 1, N C DO 100 J = 1, I Z(I,J) = A(I,J) 100 CONTINUE C IF (N .EQ. 1) GO TO 320 C ********** FOR I=N STEP -1 UNTIL 2 DO -- ********** DO 300 II = 2, N I = N + 2 - II L = I - 1 H = 0.D0 SCALE = 0.D0 IF (L .LT. 2) GO TO 130 C ********** SCALE ROW (ALGOL TOL THEN NOT NEEDED) ********** DO 120 K = 1, L 120 SCALE = SCALE + DABS(Z(I,K)) C IF (SCALE .NE. 0.D0) GO TO 140 130 E(I) = Z(I,L) GO TO 290 C 140 DO 150 K = 1, L Z(I,K) = Z(I,K) / SCALE H = H + Z(I,K) * Z(I,K) 150 CONTINUE C F = Z(I,L) G = DSQRT(H) IF (F .GE. 0.D0) G = -G E(I) = SCALE * G H = H - F * G Z(I,L) = F - G F = 0.D0 C DO 240 J = 1, L Z(J,I) = Z(I,J) / H G = 0.D0 C ********** FORM ELEMENT OF A*U ********** DO 180 K = 1, J 180 G = G + Z(J,K) * Z(I,K) C JP1 = J + 1 IF (L .LT. JP1) GO TO 220 C DO 200 K = JP1, L 200 G = G + Z(K,J) * Z(I,K) C ********** FORM ELEMENT OF P ********** 220 E(J) = G / H F = F + E(J) * Z(I,J) 240 CONTINUE C HH = F / (H + H) C ********** FORM REDUCED A ********** DO 260 J = 1, L F = Z(I,J) G = E(J) - HH * F E(J) = G C DO 260 K = 1, J Z(J,K) = Z(J,K) - F * E(K) - G * Z(I,K) 260 CONTINUE C 290 D(I) = H 300 CONTINUE C 320 D(1) = 0.D0 E(1) = 0.D0 C ********** ACCUMULATION OF TRANSFORMATION MATRICES ********** DO 500 I = 1, N L = I - 1 IF (D(I) .EQ. 0.D0) GO TO 380 C DO 360 J = 1, L G = 0.D0 C DO 340 K = 1, L 340 G = G + Z(I,K) * Z(K,J) C DO 360 K = 1, L Z(K,J) = Z(K,J) - G * Z(K,I) 360 CONTINUE C 380 D(I) = Z(I,I) Z(I,I) = 1.D0 IF (L .LT. 1) GO TO 500 C DO 400 J = 1, L Z(I,J) = 0.D0 Z(J,I) = 0.D0 400 CONTINUE C 500 CONTINUE C RETURN C ********** LAST CARD OF DTRED2 ********** END SUBROUTINE DTQL2 (NM,N,D,E,Z,IERR) C INTEGER I,J,K,L,M,N,II,L1,NM,MML,IERR DOUBLE PRECISION D(N),E(N),Z(NM,N) DOUBLE PRECISION B,C,F,G,H,P,R,S,MACHEP DOUBLE PRECISION DPMPAR C----------------------------------------------------------------------- C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE TQL2, C NUM. MATH. 11, 293-306(1968) BY BOWDLER, MARTIN, REINSCH, AND C WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 227-240(1971). C C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS C OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE QL METHOD. C THE EIGENVECTORS OF A FULL SYMMETRIC MATRIX CAN ALSO C BE FOUND IF TRED2 HAS BEEN USED TO REDUCE THIS C FULL MATRIX TO TRIDIAGONAL FORM. C C ON INPUT- C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C N IS THE ORDER OF THE MATRIX, C C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX, C C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY, C C Z CONTAINS THE TRANSFORMATION MATRIX PRODUCED IN THE C REDUCTION BY TRED2, IF PERFORMED. IF THE EIGENVECTORS C OF THE TRIDIAGONAL MATRIX ARE DESIRED, Z MUST CONTAIN C THE IDENTITY MATRIX. C C ON OUTPUT- C C D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT BUT C UNORDERED FOR INDICES 1,2,...,IERR-1, C C E HAS BEEN DESTROYED, C C Z CONTAINS ORTHONORMAL EIGENVECTORS OF THE SYMMETRIC C TRIDIAGONAL (OR FULL) MATRIX. IF AN ERROR EXIT IS MADE, C Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE STORED C EIGENVALUES, C C IERR IS SET TO C ZERO FOR NORMAL RETURN, C J IF THE J-TH EIGENVALUE HAS NOT BEEN C DETERMINED AFTER 50 ITERATIONS. C C----------------------------------------------------------------------- C C ********** MACHEP IS A MACHINE DEPENDENT PARAMETER. ASSIGN C MACHEP THE VALUE U WHERE U IS THE SMALLEST POSITIVE C FLOATING POINT NUMBER SUCH THAT 1.0 + U .GT. 1.0 . C MACHEP = DPMPAR(1) C C ********** C IERR = 0 IF (N .EQ. 1) GO TO 1001 C DO 100 I = 2, N 100 E(I-1) = E(I) C F = 0.D0 B = 0.D0 E(N) = 0.D0 C DO 240 L = 1, N J = 0 H = MACHEP * (DABS(D(L)) + DABS(E(L))) IF (B .LT. H) B = H C ********** LOOK FOR SMALL SUB-DIAGONAL ELEMENT ********** DO 110 M = L, N IF (DABS(E(M)) .LE. B) GO TO 120 C ********** E(N) IS ALWAYS ZERO, SO THERE IS NO EXIT C THROUGH THE BOTTOM OF THE LOOP ********** 110 CONTINUE C 120 IF (M .EQ. L) GO TO 220 130 IF (J .EQ. 50) GO TO 1000 J = J + 1 C ********** FORM SHIFT ********** L1 = L + 1 G = D(L) P = (D(L1) - G) / (2.D0 * E(L)) R = DSQRT(P*P + 1.D0) IF (P .LT. 0.D0) R = -R D(L) = E(L) / (P + R) H = G - D(L) C DO 140 I = L1, N 140 D(I) = D(I) - H C F = F + H C ********** QL TRANSFORMATION ********** P = D(M) C = 1.D0 S = 0.D0 MML = M - L C ********** FOR I=M-1 STEP -1 UNTIL L DO -- ********** DO 200 II = 1, MML I = M - II G = C * E(I) H = C * P IF (DABS(P) .LT. DABS(E(I))) GO TO 150 C = E(I) / P R = DSQRT(C*C + 1.D0) E(I+1) = S * P * R S = C / R C = 1.D0 / R GO TO 160 150 C = P / E(I) R = DSQRT(C*C + 1.D0) E(I+1) = S * E(I) * R S = 1.D0 / R C = C * S 160 P = C * D(I) - S * G D(I+1) = H + S * (C * G + S * D(I)) C ********** FORM VECTOR ********** DO 180 K = 1, N H = Z(K,I+1) Z(K,I+1) = S * Z(K,I) + C * H Z(K,I) = C * Z(K,I) - S * H 180 CONTINUE C 200 CONTINUE C E(L) = S * P D(L) = C * P IF (DABS(E(L)) .GT. B) GO TO 130 220 D(L) = D(L) + F 240 CONTINUE C ********** ORDER EIGENVALUES AND EIGENVECTORS ********** DO 300 II = 2, N I = II - 1 K = I P = D(I) C DO 260 J = II, N IF (D(J) .GE. P) GO TO 260 K = J P = D(J) 260 CONTINUE C IF (K .EQ. I) GO TO 300 D(K) = D(I) D(I) = P C DO 280 J = 1, N P = Z(J,I) Z(J,I) = Z(J,K) Z(J,K) = P 280 CONTINUE C 300 CONTINUE C GO TO 1001 C ********** SET ERROR -- NO CONVERGENCE TO AN C EIGENVALUE AFTER 50 ITERATIONS ********** 1000 IERR = L 1001 RETURN C ********** LAST CARD OF DTQL2 ********** END SUBROUTINE CEIG(IBAL,AR,AI,KA,N,WR,WI,IERR) C----------------------------------------------------------------------- C EIGENVALUES OF COMPLEX MATRICES C----------------------------------------------------------------------- REAL AR(KA,N), AI(KA,N), WR(N), WI(N) C LOW = 1 IGH = N IF (IBAL .NE. 0) CALL CBAL(KA,N,AR,AI,LOW,IGH,WR) CALL CORTH(KA,N,LOW,IGH,AR,AI,WR,WI) CALL COMQR(KA,N,LOW,IGH,AR,AI,WR,WI,IERR) RETURN END SUBROUTINE CEIGV(IBAL,AR,AI,KA,N,WR,WI,ZR,ZI,IERR,TEMP) C----------------------------------------------------------------------- C EIGENVALUES AND EIGENVECTORS OF COMPLEX MATRICES C----------------------------------------------------------------------- REAL AR(KA,N),AI(KA,N),WR(N),WI(N),ZR(KA,N),ZI(KA,N),TEMP(*) C---------------------- C TEMP IS A TEMPORARY STORAGE AREA C DIMENSION(TEMP) .GE. 2*N IF IBAL .EQ. 0 C DIMENSION(TEMP) .GE. 3*N IF IBAL .NE. 0 C---------------------- I2 = 1 I3 = N + 1 I1 = N + I3 LOW = 1 IGH = N IF (IBAL .NE. 0) CALL CBAL(KA,N,AR,AI,LOW,IGH,TEMP(I1)) CALL CORTH(KA,N,LOW,IGH,AR,AI,TEMP(I2),TEMP(I3)) CALL COMQR2(KA,N,LOW,IGH,TEMP(I2),TEMP(I3),AR,AI,WR,WI,ZR,ZI,IERR) IF (IERR .NE. 0) RETURN IF (IBAL .NE. 0) CALL CBABK2(KA,N,LOW,IGH,TEMP(I1),N,ZR,ZI) RETURN END SUBROUTINE CBAL(NM,N,AR,AI,LOW,IGH,SCALE) C INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC REAL AR(NM,N),AI(NM,N),SCALE(N) REAL C,F,G,R,S,B2,RADIX C REAL ABS LOGICAL NOCONV C----------------------------------------------------------------------- C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE, C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). C C THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES C EIGENVALUES WHENEVER POSSIBLE. C C ON INPUT- C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C N IS THE ORDER OF THE MATRIX, C C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED. C C ON OUTPUT- C C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE BALANCED MATRIX, C C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J) C ARE EQUAL TO ZERO IF C (1) I IS GREATER THAN J AND C (2) J=1,...,LOW-1 OR I=IGH+1,...,N, C C SCALE CONTAINS INFORMATION DETERMINING THE C PERMUTATIONS AND SCALING FACTORS USED. C C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN C SCALE(J) = P(J), FOR J = 1,...,LOW-1 C = D(J,J) J = LOW,...,IGH C = P(J) J = IGH+1,...,N. C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1, C THEN 1 TO LOW-1. C C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY. C C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN C CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS C K,L HAVE BEEN REVERSED.) C C----------------------------------------------------------------------- C C ********** RADIX IS A MACHINE DEPENDENT PARAMETER SPECIFYING C THE BASE OF THE MACHINE FLOATING POINT REPRESENTATION. C RADIX = IPMPAR(4) C C ********** C B2 = RADIX * RADIX K = 1 L = N GO TO 100 C ********** IN-LINE PROCEDURE FOR ROW AND C COLUMN EXCHANGE ********** 20 SCALE(M) = J IF (J .EQ. M) GO TO 50 C DO 30 I = 1, L F = AR(I,J) AR(I,J) = AR(I,M) AR(I,M) = F F = AI(I,J) AI(I,J) = AI(I,M) AI(I,M) = F 30 CONTINUE C DO 40 I = K, N F = AR(J,I) AR(J,I) = AR(M,I) AR(M,I) = F F = AI(J,I) AI(J,I) = AI(M,I) AI(M,I) = F 40 CONTINUE C 50 GO TO (80,130), IEXC C ********** SEARCH FOR ROWS ISOLATING AN EIGENVALUE C AND PUSH THEM DOWN ********** 80 IF (L .EQ. 1) GO TO 280 L = L - 1 C ********** FOR J=L STEP -1 UNTIL 1 DO -- ********** 100 DO 120 JJ = 1, L J = L + 1 - JJ C DO 110 I = 1, L IF (I .EQ. J) GO TO 110 IF (AR(J,I) .NE. 0.0 .OR. AI(J,I) .NE. 0.0) GO TO 120 110 CONTINUE C M = L IEXC = 1 GO TO 20 120 CONTINUE C GO TO 140 C ********** SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE C AND PUSH THEM LEFT ********** 130 K = K + 1 C 140 DO 170 J = K, L C DO 150 I = K, L IF (I .EQ. J) GO TO 150 IF (AR(I,J) .NE. 0.0 .OR. AI(I,J) .NE. 0.0) GO TO 170 150 CONTINUE C M = K IEXC = 2 GO TO 20 170 CONTINUE C ********** NOW BALANCE THE SUBMATRIX IN ROWS K TO L ********** DO 180 I = K, L 180 SCALE(I) = 1.0 C ********** ITERATIVE LOOP FOR NORM REDUCTION ********** 190 NOCONV = .FALSE. C DO 270 I = K, L C = 0.0 R = 0.0 C DO 200 J = K, L IF (J .EQ. I) GO TO 200 C = C + ABS(AR(J,I)) + ABS(AI(J,I)) R = R + ABS(AR(I,J)) + ABS(AI(I,J)) 200 CONTINUE C ********** GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ********** IF (C .EQ. 0.0 .OR. R .EQ. 0.0) GO TO 270 G = R / RADIX F = 1.0 S = C + R 210 IF (C .GE. G) GO TO 220 F = F * RADIX C = C * B2 GO TO 210 220 G = R * RADIX 230 IF (C .LT. G) GO TO 240 F = F / RADIX C = C / B2 GO TO 230 C ********** NOW BALANCE ********** 240 IF ((C + R) / F .GE. 0.95 * S) GO TO 270 G = 1.0 / F SCALE(I) = SCALE(I) * F NOCONV = .TRUE. C DO 250 J = K, N AR(I,J) = AR(I,J) * G AI(I,J) = AI(I,J) * G 250 CONTINUE C DO 260 J = 1, L AR(J,I) = AR(J,I) * F AI(J,I) = AI(J,I) * F 260 CONTINUE C 270 CONTINUE C IF (NOCONV) GO TO 190 C 280 LOW = K IGH = L RETURN C ********** LAST CARD OF CBAL ********** END SUBROUTINE CORTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI) C INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW REAL AR(NM,N),AI(NM,N),ORTR(IGH),ORTI(IGH) REAL F,G,H,FI,FR,SCALE C REAL SQRT,CABS,ABS C COMPLEX CMPLX C----------------------------------------------------------------------- C C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968) C BY MARTIN AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). C C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY C UNITARY SIMILARITY TRANSFORMATIONS. C C ON INPUT- C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C N IS THE ORDER OF THE MATRIX, C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, C SET LOW=1, IGH=N, C C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX. C C ON OUTPUT- C C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION C IS STORED IN THE REMAINING TRIANGLES UNDER THE C HESSENBERG MATRIX, C C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED. C C----------------------------------------------------------------------- LA = IGH - 1 KP1 = LOW + 1 IF (LA .LT. KP1) GO TO 200 C DO 180 M = KP1, LA H = 0.0 ORTR(M) = 0.0 ORTI(M) = 0.0 SCALE = 0.0 C ********** SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ********** DO 90 I = M, IGH 90 SCALE = SCALE + ABS(AR(I,M-1)) + ABS(AI(I,M-1)) C IF (SCALE .EQ. 0.0) GO TO 180 MP = M + IGH C ********** FOR I=IGH STEP -1 UNTIL M DO -- ********** DO 100 II = M, IGH I = MP - II ORTR(I) = AR(I,M-1) / SCALE ORTI(I) = AI(I,M-1) / SCALE H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I) 100 CONTINUE C G = SQRT(H) F = CABS(CMPLX(ORTR(M),ORTI(M))) IF (F .EQ. 0.0) GO TO 103 H = H + F * G G = G / F ORTR(M) = (1.0 + G) * ORTR(M) ORTI(M) = (1.0 + G) * ORTI(M) GO TO 105 C 103 ORTR(M) = G AR(M,M-1) = SCALE C ********** FORM (I-(U*UT)/H) * A ********** 105 DO 130 J = M, N FR = 0.0 FI = 0.0 C ********** FOR I=IGH STEP -1 UNTIL M DO -- ********** DO 110 II = M, IGH I = MP - II FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J) FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J) 110 CONTINUE C FR = FR / H FI = FI / H C DO 120 I = M, IGH AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I) AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I) 120 CONTINUE C 130 CONTINUE C ********** FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ********** DO 160 I = 1, IGH FR = 0.0 FI = 0.0 C ********** FOR J=IGH STEP -1 UNTIL M DO -- ********** DO 140 JJ = M, IGH J = MP - JJ FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J) FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J) 140 CONTINUE C FR = FR / H FI = FI / H C DO 150 J = M, IGH AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J) AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J) 150 CONTINUE C 160 CONTINUE C ORTR(M) = SCALE * ORTR(M) ORTI(M) = SCALE * ORTI(M) AR(M,M-1) = -G * AR(M,M-1) AI(M,M-1) = -G * AI(M,M-1) 180 CONTINUE C 200 RETURN C ********** LAST CARD OF CORTH ********** END SUBROUTINE COMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR) C INTEGER I,J,L,N,EN,LL,NM,IGH,ITS,LOW,LP1,ENM1,IERR REAL HR(NM,N),HI(NM,N),WR(N),WI(N) REAL SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,MACHEP COMPLEX Z3 REAL SPMPAR C INTEGER MIN0 C REAL SQRT,CABS,ABS,REAL,AIMAG C COMPLEX CSQRT,CMPLX C----------------------------------------------------------------------- C C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN C AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971). C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM. C C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX C UPPER HESSENBERG MATRIX BY THE QR METHOD. C C ON INPUT- C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C N IS THE ORDER OF THE MATRIX, C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, C SET LOW=1, IGH=N, C C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX. C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN C THE REDUCTION BY CORTH, IF PERFORMED. C C ON OUTPUT- C C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE C CALLING COMQR IF SUBSEQUENT CALCULATION OF C EIGENVECTORS IS TO BE PERFORMED, C C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT C FOR INDICES IERR+1,...,N, C C IERR IS SET TO C ZERO FOR NORMAL RETURN, C J IF THE J-TH EIGENVALUE HAS NOT BEEN C DETERMINED AFTER 30 ITERATIONS. C C ARITHMETIC IS REAL EXCEPT FOR THE REPLACEMENT OF THE ALGOL C PROCEDURE CDIV BY COMPLEX DIVISION AND USE OF THE SUBROUTINES C CSQRT AND CMPLX IN COMPUTING COMPLEX SQUARE ROOTS. C C----------------------------------------------------------------------- C C ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING C THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC. C MACHEP = SPMPAR(1) C C ********** C IERR = 0 IF (LOW .EQ. IGH) GO TO 180 C ********** CREATE REAL SUBDIAGONAL ELEMENTS ********** L = LOW + 1 C DO 170 I = L, IGH LL = MIN0(I+1,IGH) IF (HI(I,I-1) .EQ. 0.0) GO TO 170 NORM = CABS(CMPLX(HR(I,I-1),HI(I,I-1))) YR = HR(I,I-1) / NORM YI = HI(I,I-1) / NORM HR(I,I-1) = NORM HI(I,I-1) = 0.0 C DO 155 J = I, IGH SI = YR * HI(I,J) - YI * HR(I,J) HR(I,J) = YR * HR(I,J) + YI * HI(I,J) HI(I,J) = SI 155 CONTINUE C DO 160 J = LOW, LL SI = YR * HI(J,I) + YI * HR(J,I) HR(J,I) = YR * HR(J,I) - YI * HI(J,I) HI(J,I) = SI 160 CONTINUE C 170 CONTINUE C ********** STORE ROOTS ISOLATED BY CBAL ********** 180 DO 200 I = 1, N IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200 WR(I) = HR(I,I) WI(I) = HI(I,I) 200 CONTINUE C EN = IGH TR = 0.0 TI = 0.0 C ********** SEARCH FOR NEXT EIGENVALUE ********** 220 IF (EN .LT. LOW) GO TO 1001 ITS = 0 ENM1 = EN - 1 C ********** LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT C FOR L=EN STEP -1 UNTIL LOW -- ********** 240 DO 260 LL = LOW, EN L = EN + LOW - LL IF (L .EQ. LOW) GO TO 300 IF (ABS(HR(L,L-1)) .LE. X MACHEP * (ABS(HR(L-1,L-1)) + ABS(HI(L-1,L-1)) X + ABS(HR(L,L)) +ABS(HI(L,L)))) GO TO 300 260 CONTINUE C ********** FORM SHIFT ********** 300 IF (L .EQ. EN) GO TO 660 IF (ITS .EQ. 30) GO TO 1000 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320 SR = HR(EN,EN) SI = HI(EN,EN) XR = HR(ENM1,EN) * HR(EN,ENM1) XI = HI(ENM1,EN) * HR(EN,ENM1) IF (XR .EQ. 0.0 .AND. XI .EQ. 0.0) GO TO 340 YR = (HR(ENM1,ENM1) - SR) / 2.0 YI = (HI(ENM1,ENM1) - SI) / 2.0 Z3 = CSQRT(CMPLX(YR**2-YI**2+XR,2.0*YR*YI+XI)) ZZR = REAL(Z3) ZZI = AIMAG(Z3) IF (YR * ZZR + YI * ZZI .GE. 0.0) GO TO 310 ZZR = -ZZR ZZI = -ZZI 310 Z3 = CMPLX(XR,XI) / CMPLX(YR+ZZR,YI+ZZI) SR = SR - REAL(Z3) SI = SI - AIMAG(Z3) GO TO 340 C ********** FORM EXCEPTIONAL SHIFT ********** 320 SR = ABS(HR(EN,ENM1)) + ABS(HR(ENM1,EN-2)) SI = 0.0 C 340 DO 360 I = LOW, EN HR(I,I) = HR(I,I) - SR HI(I,I) = HI(I,I) - SI 360 CONTINUE C TR = TR + SR TI = TI + SI ITS = ITS + 1 C ********** REDUCE TO TRIANGLE (ROWS) ********** LP1 = L + 1 C DO 500 I = LP1, EN SR = HR(I,I-1) HR(I,I-1) = 0.0 NORM = SQRT(HR(I-1,I-1)*HR(I-1,I-1)+HI(I-1,I-1)*HI(I-1,I-1) X +SR*SR) XR = HR(I-1,I-1) / NORM WR(I-1) = XR XI = HI(I-1,I-1) / NORM WI(I-1) = XI HR(I-1,I-1) = NORM HI(I-1,I-1) = 0.0 HI(I,I-1) = SR / NORM C DO 490 J = I, EN YR = HR(I-1,J) YI = HI(I-1,J) ZZR = HR(I,J) ZZI = HI(I,J) HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI 490 CONTINUE C 500 CONTINUE C SI = HI(EN,EN) IF (SI .EQ. 0.0) GO TO 540 NORM = CABS(CMPLX(HR(EN,EN),SI)) SR = HR(EN,EN) / NORM SI = SI / NORM HR(EN,EN) = NORM HI(EN,EN) = 0.0 C ********** INVERSE OPERATION (COLUMNS) ********** 540 DO 600 J = LP1, EN XR = WR(J-1) XI = WI(J-1) C DO 580 I = L, J YR = HR(I,J-1) YI = 0.0 ZZR = HR(I,J) ZZI = HI(I,J) IF (I .EQ. J) GO TO 560 YI = HI(I,J-1) HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI 560 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI 580 CONTINUE C 600 CONTINUE C IF (SI .EQ. 0.0) GO TO 240 C DO 630 I = L, EN YR = HR(I,EN) YI = HI(I,EN) HR(I,EN) = SR * YR - SI * YI HI(I,EN) = SR * YI + SI * YR 630 CONTINUE C GO TO 240 C ********** A ROOT FOUND ********** 660 WR(EN) = HR(EN,EN) + TR WI(EN) = HI(EN,EN) + TI EN = ENM1 GO TO 220 C ********** SET ERROR -- NO CONVERGENCE TO AN C EIGENVALUE AFTER 30 ITERATIONS ********** 1000 IERR = EN 1001 RETURN C ********** LAST CARD OF COMQR ********** END SUBROUTINE CBABK2(NM,N,LOW,IGH,SCALE,M,ZR,ZI) C INTEGER I,J,K,M,N,II,NM,IGH,LOW REAL SCALE(N),ZR(NM,M),ZI(NM,M) REAL S C----------------------------------------------------------------------- C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK, C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). C C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING C BALANCED MATRIX DETERMINED BY CBAL. C C ON INPUT- C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C N IS THE ORDER OF THE MATRIX, C C LOW AND IGH ARE INTEGERS DETERMINED BY CBAL, C C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS C AND SCALING FACTORS USED BY CBAL, C C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED, C C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE EIGENVECTORS TO BE C BACK TRANSFORMED IN THEIR FIRST M COLUMNS. C C ON OUTPUT- C C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS C IN THEIR FIRST M COLUMNS. C C----------------------------------------------------------------------- IF (M .EQ. 0) GO TO 200 IF (IGH .EQ. LOW) GO TO 120 C DO 110 I = LOW, IGH S = SCALE(I) C ********** LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED C IF THE FOREGOING STATEMENT IS REPLACED BY C S=1.0/SCALE(I). ********** DO 100 J = 1, M ZR(I,J) = ZR(I,J) * S ZI(I,J) = ZI(I,J) * S 100 CONTINUE C 110 CONTINUE C ********** FOR I=LOW-1 STEP -1 UNTIL 1, C IGH+1 STEP 1 UNTIL N DO -- ********** 120 DO 140 II = 1, N I = II IF (I .GE. LOW .AND. I .LE. IGH) GO TO 140 IF (I .LT. LOW) I = LOW - II K = SCALE(I) IF (K .EQ. I) GO TO 140 C DO 130 J = 1, M S = ZR(I,J) ZR(I,J) = ZR(K,J) ZR(K,J) = S S = ZI(I,J) ZI(I,J) = ZI(K,J) ZI(K,J) = S 130 CONTINUE C 140 CONTINUE C 200 RETURN C ********** LAST CARD OF CBABK2 ********** END SUBROUTINE COMQR2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR) C INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1, * ITS,LOW,LP1,ENM1,IEND,IERR REAL HR(NM,N),HI(NM,N),WR(N),WI(N),ZR(NM,N),ZI(NM,N), * ORTR(IGH),ORTI(IGH) REAL SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,MACHEP COMPLEX Z3 REAL SPMPAR C INTEGER MIN0 C REAL SQRT,CABS,ABS,REAL,AIMAG C COMPLEX CSQRT,CMPLX C----------------------------------------------------------------------- C C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS C AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM. C C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE C THIS GENERAL MATRIX TO HESSENBERG FORM. C C ON INPUT- C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C N IS THE ORDER OF THE MATRIX, C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED, C SET LOW=1, IGH=N, C C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS- C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED. C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND C ORTI(J) TO 0.0 FOR THESE ELEMENTS, C C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX. C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE C ARBITRARY. C C ON OUTPUT- C C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI C HAVE BEEN DESTROYED, C C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT C FOR INDICES IERR+1,...,N, C C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF C THE EIGENVECTORS HAS BEEN FOUND, C C IERR IS SET TO C ZERO FOR NORMAL RETURN, C J IF THE J-TH EIGENVALUE HAS NOT BEEN C DETERMINED AFTER 30 ITERATIONS. C C ARITHMETIC IS REAL EXCEPT FOR THE REPLACEMENT OF THE ALGOL C PROCEDURE CDIV BY COMPLEX DIVISION AND USE OF THE SUBROUTINES C CSQRT AND CMPLX IN COMPUTING COMPLEX SQUARE ROOTS. C C----------------------------------------------------------------------- C C ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING C THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC. C MACHEP = SPMPAR(1) C C ********** C IERR = 0 C ********** INITIALIZE EIGENVECTOR MATRIX ********** DO 100 I = 1, N C DO 100 J = 1, N ZR(I,J) = 0.0 ZI(I,J) = 0.0 IF (I .EQ. J) ZR(I,J) = 1.0 100 CONTINUE C ********** FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS C FROM THE INFORMATION LEFT BY CORTH ********** IEND = IGH - LOW - 1 IF (IEND) 180, 150, 105 C ********** FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ********** 105 DO 140 II = 1, IEND I = IGH - II IF (ORTR(I) .EQ. 0.0 .AND. ORTI(I) .EQ. 0.0) GO TO 140 IF (HR(I,I-1) .EQ. 0.0 .AND. HI(I,I-1) .EQ. 0.0) GO TO 140 C ********** NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ********** NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I) IP1 = I + 1 C DO 110 K = IP1, IGH ORTR(K) = HR(K,I-1) ORTI(K) = HI(K,I-1) 110 CONTINUE C DO 130 J = I, IGH SR = 0.0 SI = 0.0 C DO 115 K = I, IGH SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J) SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J) 115 CONTINUE C SR = SR / NORM SI = SI / NORM C DO 120 K = I, IGH ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K) ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K) 120 CONTINUE C 130 CONTINUE C 140 CONTINUE C ********** CREATE REAL SUBDIAGONAL ELEMENTS ********** 150 L = LOW + 1 C DO 170 I = L, IGH LL = MIN0(I+1,IGH) IF (HI(I,I-1) .EQ. 0.0) GO TO 170 NORM = CABS(CMPLX(HR(I,I-1),HI(I,I-1))) YR = HR(I,I-1) / NORM YI = HI(I,I-1) / NORM HR(I,I-1) = NORM HI(I,I-1) = 0.0 C DO 155 J = I, N SI = YR * HI(I,J) - YI * HR(I,J) HR(I,J) = YR * HR(I,J) + YI * HI(I,J) HI(I,J) = SI 155 CONTINUE C DO 160 J = 1, LL SI = YR * HI(J,I) + YI * HR(J,I) HR(J,I) = YR * HR(J,I) - YI * HI(J,I) HI(J,I) = SI 160 CONTINUE C DO 165 J = LOW, IGH SI = YR * ZI(J,I) + YI * ZR(J,I) ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I) ZI(J,I) = SI 165 CONTINUE C 170 CONTINUE C ********** STORE ROOTS ISOLATED BY CBAL ********** 180 DO 200 I = 1, N IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200 WR(I) = HR(I,I) WI(I) = HI(I,I) 200 CONTINUE C EN = IGH TR = 0.0 TI = 0.0 C ********** SEARCH FOR NEXT EIGENVALUE ********** 220 IF (EN .LT. LOW) GO TO 680 ITS = 0 ENM1 = EN - 1 C ********** LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT C FOR L=EN STEP -1 UNTIL LOW DO -- ********** 240 DO 260 LL = LOW, EN L = EN + LOW - LL IF (L .EQ. LOW) GO TO 300 IF (ABS(HR(L,L-1)) .LE. X MACHEP * (ABS(HR(L-1,L-1)) + ABS(HI(L-1,L-1)) X + ABS(HR(L,L)) +ABS(HI(L,L)))) GO TO 300 260 CONTINUE C ********** FORM SHIFT ********** 300 IF (L .EQ. EN) GO TO 660 IF (ITS .EQ. 30) GO TO 1000 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GO TO 320 SR = HR(EN,EN) SI = HI(EN,EN) XR = HR(ENM1,EN) * HR(EN,ENM1) XI = HI(ENM1,EN) * HR(EN,ENM1) IF (XR .EQ. 0.0 .AND. XI .EQ. 0.0) GO TO 340 YR = (HR(ENM1,ENM1) - SR) / 2.0 YI = (HI(ENM1,ENM1) - SI) / 2.0 Z3 = CSQRT(CMPLX(YR**2-YI**2+XR,2.0*YR*YI+XI)) ZZR = REAL(Z3) ZZI = AIMAG(Z3) IF (YR * ZZR + YI * ZZI .GE. 0.0) GO TO 310 ZZR = -ZZR ZZI = -ZZI 310 Z3 = CMPLX(XR,XI) / CMPLX(YR+ZZR,YI+ZZI) SR = SR - REAL(Z3) SI = SI - AIMAG(Z3) GO TO 340 C ********** FORM EXCEPTIONAL SHIFT ********** 320 SR = ABS(HR(EN,ENM1)) + ABS(HR(ENM1,EN-2)) SI = 0.0 C 340 DO 360 I = LOW, EN HR(I,I) = HR(I,I) - SR HI(I,I) = HI(I,I) - SI 360 CONTINUE C TR = TR + SR TI = TI + SI ITS = ITS + 1 C ********** REDUCE TO TRIANGLE (ROWS) ********** LP1 = L + 1 C DO 500 I = LP1, EN SR = HR(I,I-1) HR(I,I-1) = 0.0 NORM = SQRT(HR(I-1,I-1)*HR(I-1,I-1)+HI(I-1,I-1)*HI(I-1,I-1) X +SR*SR) XR = HR(I-1,I-1) / NORM WR(I-1) = XR XI = HI(I-1,I-1) / NORM WI(I-1) = XI HR(I-1,I-1) = NORM HI(I-1,I-1) = 0.0 HI(I,I-1) = SR / NORM C DO 490 J = I, N YR = HR(I-1,J) YI = HI(I-1,J) ZZR = HR(I,J) ZZI = HI(I,J) HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI 490 CONTINUE C 500 CONTINUE C SI = HI(EN,EN) IF (SI .EQ. 0.0) GO TO 540 NORM = CABS(CMPLX(HR(EN,EN),SI)) SR = HR(EN,EN) / NORM SI = SI / NORM HR(EN,EN) = NORM HI(EN,EN) = 0.0 IF (EN .EQ. N) GO TO 540 IP1 = EN + 1 C DO 520 J = IP1, N YR = HR(EN,J) YI = HI(EN,J) HR(EN,J) = SR * YR + SI * YI HI(EN,J) = SR * YI - SI * YR 520 CONTINUE C ********** INVERSE OPERATION (COLUMNS) ********** 540 DO 600 J = LP1, EN XR = WR(J-1) XI = WI(J-1) C DO 580 I = 1, J YR = HR(I,J-1) YI = 0.0 ZZR = HR(I,J) ZZI = HI(I,J) IF (I .EQ. J) GO TO 560 YI = HI(I,J-1) HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI 560 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI 580 CONTINUE C DO 590 I = LOW, IGH YR = ZR(I,J-1) YI = ZI(I,J-1) ZZR = ZR(I,J) ZZI = ZI(I,J) ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI 590 CONTINUE C 600 CONTINUE C IF (SI .EQ. 0.0) GO TO 240 C DO 630 I = 1, EN YR = HR(I,EN) YI = HI(I,EN) HR(I,EN) = SR * YR - SI * YI HI(I,EN) = SR * YI + SI * YR 630 CONTINUE C DO 640 I = LOW, IGH YR = ZR(I,EN) YI = ZI(I,EN) ZR(I,EN) = SR * YR - SI * YI ZI(I,EN) = SR * YI + SI * YR 640 CONTINUE C GO TO 240 C ********** A ROOT FOUND ********** 660 HR(EN,EN) = HR(EN,EN) + TR WR(EN) = HR(EN,EN) HI(EN,EN) = HI(EN,EN) + TI WI(EN) = HI(EN,EN) EN = ENM1 GO TO 220 C ********** ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND C VECTORS OF UPPER TRIANGULAR FORM ********** 680 NORM = 0.0 C DO 720 I = 1, N C DO 720 J = I, N NORM = NORM + ABS(HR(I,J)) + ABS(HI(I,J)) 720 CONTINUE C IF (N .EQ. 1 .OR. NORM .EQ. 0.0) GO TO 1001 C ********** FOR EN=N STEP -1 UNTIL 2 DO -- ********** DO 800 NN = 2, N EN = N + 2 - NN XR = WR(EN) XI = WI(EN) ENM1 = EN - 1 C ********** FOR I=EN-1 STEP -1 UNTIL 1 DO -- ********** DO 780 II = 1, ENM1 I = EN - II ZZR = HR(I,EN) ZZI = HI(I,EN) IF (I .EQ. ENM1) GO TO 760 IP1 = I + 1 C DO 740 J = IP1, ENM1 ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN) ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN) 740 CONTINUE C 760 YR = XR - WR(I) YI = XI - WI(I) IF (YR .EQ. 0.0 .AND. YI .EQ. 0.0) YR = MACHEP * NORM Z3 = CMPLX(ZZR,ZZI) / CMPLX(YR,YI) HR(I,EN) = REAL(Z3) HI(I,EN) = AIMAG(Z3) 780 CONTINUE C 800 CONTINUE C ********** END BACKSUBSTITUTION ********** ENM1 = N - 1 C ********** VECTORS OF ISOLATED ROOTS ********** DO 840 I = 1, ENM1 IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840 IP1 = I + 1 C DO 820 J = IP1, N ZR(I,J) = HR(I,J) ZI(I,J) = HI(I,J) 820 CONTINUE C 840 CONTINUE C ********** MULTIPLY BY TRANSFORMATION MATRIX TO GIVE C VECTORS OF ORIGINAL FULL MATRIX. C FOR J=N STEP -1 UNTIL LOW+1 DO -- ********** DO 880 JJ = LOW, ENM1 J = N + LOW - JJ M = MIN0(J-1,IGH) C DO 880 I = LOW, IGH ZZR = ZR(I,J) ZZI = ZI(I,J) C DO 860 K = LOW, M ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J) ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J) 860 CONTINUE C ZR(I,J) = ZZR ZI(I,J) = ZZI 880 CONTINUE C GO TO 1001 C ********** SET ERROR -- NO CONVERGENCE TO AN C EIGENVALUE AFTER 30 ITERATIONS ********** 1000 IERR = EN 1001 RETURN C ********** LAST CARD OF COMQR2 ********** END SUBROUTINE DCEIG(IBAL,AR,AI,KA,N,WR,WI,IERR) C----------------------------------------------------------------------- C EIGENVALUES OF DOUBLE PRECISION COMPLEX MATRICES C----------------------------------------------------------------------- DOUBLE PRECISION AR(KA,N), AI(KA,N), WR(N), WI(N) C LOW = 1 IGH = N IF (IBAL .NE. 0) CALL DCBAL(KA,N,AR,AI,LOW,IGH,WR) CALL DCORTH(KA,N,LOW,IGH,AR,AI,WR,WI) CALL DCOMQR(KA,N,LOW,IGH,AR,AI,WR,WI,IERR) RETURN END SUBROUTINE DCEIGV (IBAL,AR,AI,KA,N,WR,WI,ZR,ZI,IERR,TEMP) C----------------------------------------------------------------------- C EIGENVALUES AND EIGENVECTORS C OF DOUBLE PRECISION COMPLEX MATRICES C----------------------------------------------------------------------- DOUBLE PRECISION AR(KA,N),AI(KA,N),WR(N),WI(N),ZR(KA,N),ZI(KA,N), * TEMP(*) C---------------------- C TEMP IS A TEMPORARY STORAGE AREA C DIMENSION(TEMP) .GE. 2*N IF IBAL .EQ. 0 C DIMENSION(TEMP) .GE. 3*N IF IBAL .NE. 0 C---------------------- I2 = 1 I3 = N + 1 I1 = N + I3 LOW = 1 IGH = N IF (IBAL .NE. 0) CALL DCBAL(KA,N,AR,AI,LOW,IGH,TEMP(I1)) CALL DCORTH(KA,N,LOW,IGH,AR,AI,TEMP(I2),TEMP(I3)) CALL DCMQR2(KA,N,LOW,IGH,TEMP(I2),TEMP(I3),AR,AI,WR,WI, * ZR,ZI,IERR) IF (IERR .NE. 0) RETURN IF (IBAL .NE. 0) CALL DCBABK(KA,N,LOW,IGH,TEMP(I1),N,ZR,ZI) RETURN END SUBROUTINE DCBAL(NM,N,AR,AI,LOW,IGH,SCALE) C INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC DOUBLE PRECISION AR(NM,N),AI(NM,N),SCALE(N) DOUBLE PRECISION C,F,G,R,S,B2,RADIX LOGICAL NOCONV C----------------------------------------------------------------------- C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE, C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). C C DCBAL BALANCES A DOUBLE PRECISION COMPLEX MATRIX AND C ISOLATES EIGENVALUES WHENEVER POSSIBLE. C C ON INPUT- C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C N IS THE ORDER OF THE MATRIX, C C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED. C C ON OUTPUT- C C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE BALANCED MATRIX, C C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J) C ARE EQUAL TO ZERO IF C (1) I IS GREATER THAN J AND C (2) J=1,...,LOW-1 OR I=IGH+1,...,N, C C SCALE CONTAINS INFORMATION DETERMINING THE C PERMUTATIONS AND SCALING FACTORS USED. C C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN C SCALE(J) = P(J), FOR J = 1,...,LOW-1 C = D(J,J) J = LOW,...,IGH C = P(J) J = IGH+1,...,N. C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1, C THEN 1 TO LOW-1. C C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY. C C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN C DCBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS C K,L HAVE BEEN REVERSED.) C C----------------------------------------------------------------------- C C ********** RADIX IS A MACHINE DEPENDENT PARAMETER SPECIFYING C THE BASE OF THE MACHINE FLOATING POINT REPRESENTATION. C RADIX = IPMPAR(4) C C ********** C B2 = RADIX * RADIX K = 1 L = N GO TO 100 C ********** IN-LINE PROCEDURE FOR ROW AND C COLUMN EXCHANGE ********** 20 SCALE(M) = J IF (J .EQ. M) GO TO 50 C DO 30 I = 1, L F = AR(I,J) AR(I,J) = AR(I,M) AR(I,M) = F F = AI(I,J) AI(I,J) = AI(I,M) AI(I,M) = F 30 CONTINUE C DO 40 I = K, N F = AR(J,I) AR(J,I) = AR(M,I) AR(M,I) = F F = AI(J,I) AI(J,I) = AI(M,I) AI(M,I) = F 40 CONTINUE C 50 GO TO (80,130), IEXC C ********** SEARCH FOR ROWS ISOLATING AN EIGENVALUE C AND PUSH THEM DOWN ********** 80 IF (L .EQ. 1) GO TO 280 L = L - 1 C ********** FOR J=L STEP -1 UNTIL 1 DO -- ********** 100 DO 120 JJ = 1, L J = L + 1 - JJ C DO 110 I = 1, L IF (I .EQ. J) GO TO 110 IF (AR(J,I) .NE. 0.D0 .OR. AI(J,I) .NE. 0.D0) GO TO 120 110 CONTINUE C M = L IEXC = 1 GO TO 20 120 CONTINUE C GO TO 140 C ********** SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE C AND PUSH THEM LEFT ********** 130 K = K + 1 C 140 DO 170 J = K, L C DO 150 I = K, L IF (I .EQ. J) GO TO 150 IF (AR(I,J) .NE. 0.D0 .OR. AI(I,J) .NE. 0.D0) GO TO 170 150 CONTINUE C M = K IEXC = 2 GO TO 20 170 CONTINUE C ********** NOW BALANCE THE SUBMATRIX IN ROWS K TO L ********** DO 180 I = K, L 180 SCALE(I) = 1.D0 C ********** ITERATIVE LOOP FOR NORM REDUCTION ********** 190 NOCONV = .FALSE. C DO 270 I = K, L C = 0.D0 R = 0.D0 C DO 200 J = K, L IF (J .EQ. I) GO TO 200 C = C + DABS(AR(J,I)) + DABS(AI(J,I)) R = R + DABS(AR(I,J)) + DABS(AI(I,J)) 200 CONTINUE C ********** GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ********** IF (C .EQ. 0.D0 .OR. R .EQ. 0.D0) GO TO 270 G = R / RADIX F = 1.D0 S = C + R 210 IF (C .GE. G) GO TO 220 F = F * RADIX C = C * B2 GO TO 210 220 G = R * RADIX 230 IF (C .LT. G) GO TO 240 F = F / RADIX C = C / B2 GO TO 230 C ********** NOW BALANCE ********** 240 IF ((C + R) / F .GE. 0.95D0 * S) GO TO 270 G = 1.D0 / F SCALE(I) = SCALE(I) * F NOCONV = .TRUE. C DO 250 J = K, N AR(I,J) = AR(I,J) * G AI(I,J) = AI(I,J) * G 250 CONTINUE C DO 260 J = 1, L AR(J,I) = AR(J,I) * F AI(J,I) = AI(J,I) * F 260 CONTINUE C 270 CONTINUE C IF (NOCONV) GO TO 190 C 280 LOW = K IGH = L RETURN C ********** LAST CARD OF DCBAL ********** END SUBROUTINE DCORTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI) C INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW DOUBLE PRECISION AR(NM,N),AI(NM,N),ORTR(IGH),ORTI(IGH) DOUBLE PRECISION F,G,H,FI,FR,SCALE DOUBLE PRECISION DCPABS C----------------------------------------------------------------------- C C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968) C BY MARTIN AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971). C C GIVEN A DOUBLE PRECISION COMPLEX MATRIX, DCORTH C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY C UNITARY SIMILARITY TRANSFORMATIONS. C C ON INPUT- C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C N IS THE ORDER OF THE MATRIX, C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE DCBAL. IF DCBAL HAS NOT BEEN USED, C SET LOW=1, IGH=N, C C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX. C C ON OUTPUT- C C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION C IS STORED IN THE REMAINING TRIANGLES UNDER THE C HESSENBERG MATRIX, C C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED. C C----------------------------------------------------------------------- LA = IGH - 1 KP1 = LOW + 1 IF (LA .LT. KP1) GO TO 200 C DO 180 M = KP1, LA H = 0.D0 ORTR(M) = 0.D0 ORTI(M) = 0.D0 SCALE = 0.D0 C ********** SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ********** DO 90 I = M, IGH 90 SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1)) C IF (SCALE .EQ. 0.D0) GO TO 180 MP = M + IGH C ********** FOR I=IGH STEP -1 UNTIL M DO -- ********** DO 100 II = M, IGH I = MP - II ORTR(I) = AR(I,M-1) / SCALE ORTI(I) = AI(I,M-1) / SCALE H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I) 100 CONTINUE C G = DSQRT(H) F = DCPABS(ORTR(M),ORTI(M)) IF (F .EQ. 0.D0) GO TO 103 H = H + F * G G = G / F ORTR(M) = (1.D0 + G) * ORTR(M) ORTI(M) = (1.D0 + G) * ORTI(M) GO TO 105 C 103 ORTR(M) = G AR(M,M-1) = SCALE C ********** FORM (I-(U*UT)/H) * A ********** 105 DO 130 J = M, N FR = 0.D0 FI = 0.D0 C ********** FOR I=IGH STEP -1 UNTIL M DO -- ********** DO 110 II = M, IGH I = MP - II FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J) FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J) 110 CONTINUE C FR = FR / H FI = FI / H C DO 120 I = M, IGH AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I) AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I) 120 CONTINUE C 130 CONTINUE C ********** FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ********** DO 160 I = 1, IGH FR = 0.D0 FI = 0.D0 C ********** FOR J=IGH STEP -1 UNTIL M DO -- ********** DO 140 JJ = M, IGH J = MP - JJ FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J) FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J) 140 CONTINUE C FR = FR / H FI = FI / H C DO 150 J = M, IGH AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J) AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J) 150 CONTINUE C 160 CONTINUE C ORTR(M) = SCALE * ORTR(M) ORTI(M) = SCALE * ORTI(M) AR(M,M-1) = -G * AR(M,M-1) AI(M,M-1) = -G * AI(M,M-1) 180 CONTINUE C 200 RETURN C ********** LAST CARD OF DCORTH ********** END SUBROUTINE DCOMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR) C INTEGER I,J,L,N,EN,LL,NM,IGH,ITS,LOW,LP1,ENM1,IERR DOUBLE PRECISION HR(NM,N),HI(NM,N),WR(N),WI(N) DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,MACHEP DOUBLE PRECISION R2,W(2),Z(2) DOUBLE PRECISION DPMPAR,DCPABS C----------------------------------------------------------------------- C C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN C AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971). C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM. C C THIS SUBROUTINE FINDS THE EIGENVALUES OF A DOUBLE PRECISION C COMPLEX UPPER HESSENBERG MATRIX BY THE QR METHOD. C C ON INPUT- C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C N IS THE ORDER OF THE MATRIX, C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE DCBAL. IF DCBAL HAS NOT BEEN USED, C SET LOW=1, IGH=N, C C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX. C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN C THE REDUCTION BY DCORTH, IF PERFORMED. C C ON OUTPUT- C C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE C CALLING DCOMQR IF SUBSEQUENT CALCULATION OF C EIGENVECTORS IS TO BE PERFORMED, C C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT C FOR INDICES IERR+1,...,N, C C IERR IS SET TO C ZERO FOR NORMAL RETURN, C J IF THE J-TH EIGENVALUE HAS NOT BEEN C DETERMINED AFTER 50 ITERATIONS. C C----------------------------------------------------------------------- C C ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING C THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC. C MACHEP = DPMPAR(1) C C ********** C IERR = 0 IF (LOW .EQ. IGH) GO TO 180 C ********** CREATE REAL SUBDIAGONAL ELEMENTS ********** L = LOW + 1 C DO 170 I = L, IGH LL = MIN0(I+1,IGH) IF (HI(I,I-1) .EQ. 0.D0) GO TO 170 NORM = DCPABS(HR(I,I-1),HI(I,I-1)) YR = HR(I,I-1) / NORM YI = HI(I,I-1) / NORM HR(I,I-1) = NORM HI(I,I-1) = 0.D0 C DO 155 J = I, IGH SI = YR * HI(I,J) - YI * HR(I,J) HR(I,J) = YR * HR(I,J) + YI * HI(I,J) HI(I,J) = SI 155 CONTINUE C DO 160 J = LOW, LL SI = YR * HI(J,I) + YI * HR(J,I) HR(J,I) = YR * HR(J,I) - YI * HI(J,I) HI(J,I) = SI 160 CONTINUE C 170 CONTINUE C ********** STORE ROOTS ISOLATED BY DCBAL ********** 180 DO 200 I = 1, N IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200 WR(I) = HR(I,I) WI(I) = HI(I,I) 200 CONTINUE C EN = IGH TR = 0.D0 TI = 0.D0 C ********** SEARCH FOR NEXT EIGENVALUE ********** 220 IF (EN .LT. LOW) GO TO 1001 ITS = 0 ENM1 = EN - 1 C ********** LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT C FOR L=EN STEP -1 UNTIL LOW -- ********** 240 DO 260 LL = LOW, EN L = EN + LOW - LL IF (L .EQ. LOW) GO TO 300 IF (DABS(HR(L,L-1)) .LE. X MACHEP * (DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1)) X + DABS(HR(L,L)) + DABS(HI(L,L)))) GO TO 300 260 CONTINUE C ********** FORM SHIFT ********** 300 IF (L .EQ. EN) GO TO 660 IF (ITS .EQ. 50) GO TO 1000 IF (ITS .EQ. 10 .OR. ITS .EQ. 20 .OR. ITS .EQ. 30) GO TO 320 SR = HR(EN,EN) SI = HI(EN,EN) XR = HR(ENM1,EN) * HR(EN,ENM1) XI = HI(ENM1,EN) * HR(EN,ENM1) IF (XR .EQ. 0.D0 .AND. XI .EQ. 0.D0) GO TO 340 YR = (HR(ENM1,ENM1) - SR) / 2.D0 YI = (HI(ENM1,ENM1) - SI) / 2.D0 Z(1) = YR*YR - YI*YI + XR Z(2) = 2.D0*YR*YI + XI CALL DCSQRT(Z,W) ZZR = W(1) ZZI = W(2) IF (YR * ZZR + YI * ZZI .GE. 0.D0) GO TO 310 ZZR = -ZZR ZZI = -ZZI 310 Z(1) = YR + ZZR Z(2) = YI + ZZI R2 = Z(1)**2 + Z(2)**2 SR = SR - (XR*Z(1) + XI*Z(2))/R2 SI = SI - (XI*Z(1) - XR*Z(2))/R2 GO TO 340 C ********** FORM EXCEPTIONAL SHIFT ********** 320 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2)) SI = 0.D0 C 340 DO 360 I = LOW, EN HR(I,I) = HR(I,I) - SR HI(I,I) = HI(I,I) - SI 360 CONTINUE C TR = TR + SR TI = TI + SI ITS = ITS + 1 C ********** REDUCE TO TRIANGLE (ROWS) ********** LP1 = L + 1 C DO 500 I = LP1, EN SR = HR(I,I-1) HR(I,I-1) = 0.D0 NORM = DSQRT(HR(I-1,I-1)*HR(I-1,I-1)+HI(I-1,I-1)*HI(I-1,I-1) X + SR*SR) XR = HR(I-1,I-1) / NORM WR(I-1) = XR XI = HI(I-1,I-1) / NORM WI(I-1) = XI HR(I-1,I-1) = NORM HI(I-1,I-1) = 0.D0 HI(I,I-1) = SR / NORM C DO 490 J = I, EN YR = HR(I-1,J) YI = HI(I-1,J) ZZR = HR(I,J) ZZI = HI(I,J) HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI 490 CONTINUE C 500 CONTINUE C SI = HI(EN,EN) IF (SI .EQ. 0.D0) GO TO 540 NORM = DCPABS(HR(EN,EN),SI) SR = HR(EN,EN) / NORM SI = SI / NORM HR(EN,EN) = NORM HI(EN,EN) = 0.D0 C ********** INVERSE OPERATION (COLUMNS) ********** 540 DO 600 J = LP1, EN XR = WR(J-1) XI = WI(J-1) C DO 580 I = L, J YR = HR(I,J-1) YI = 0.D0 ZZR = HR(I,J) ZZI = HI(I,J) IF (I .EQ. J) GO TO 560 YI = HI(I,J-1) HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI 560 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI 580 CONTINUE C 600 CONTINUE C IF (SI .EQ. 0.D0) GO TO 240 C DO 630 I = L, EN YR = HR(I,EN) YI = HI(I,EN) HR(I,EN) = SR * YR - SI * YI HI(I,EN) = SR * YI + SI * YR 630 CONTINUE C GO TO 240 C ********** A ROOT FOUND ********** 660 WR(EN) = HR(EN,EN) + TR WI(EN) = HI(EN,EN) + TI EN = ENM1 GO TO 220 C ********** SET ERROR -- NO CONVERGENCE TO AN C EIGENVALUE AFTER 50 ITERATIONS ********** 1000 IERR = EN 1001 RETURN END SUBROUTINE DCBABK (NM,N,LOW,IGH,SCALE,M,ZR,ZI) C INTEGER I,J,K,M,N,II,NM,IGH,LOW DOUBLE PRECISION SCALE(N),ZR(NM,M),ZI(NM,M) DOUBLE PRECISION S C----------------------------------------------------------------------- C C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK, C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971). C C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A DOUBLE PRECISION C COMPLEX MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING C BALANCED MATRIX DETERMINED BY DCBAL. C C ON INPUT- C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C N IS THE ORDER OF THE MATRIX, C C LOW AND IGH ARE INTEGERS DETERMINED BY DCBAL, C C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS C AND SCALING FACTORS USED BY DCBAL, C C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED, C C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE EIGENVECTORS TO BE C BACK TRANSFORMED IN THEIR FIRST M COLUMNS. C C ON OUTPUT- C C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS C IN THEIR FIRST M COLUMNS. C C----------------------------------------------------------------------- IF (M .EQ. 0) GO TO 200 IF (IGH .EQ. LOW) GO TO 120 C DO 110 I = LOW, IGH S = SCALE(I) C ********** LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED C IF THE FOREGOING STATEMENT IS REPLACED BY C S=1.0/SCALE(I). ********** DO 100 J = 1, M ZR(I,J) = ZR(I,J) * S ZI(I,J) = ZI(I,J) * S 100 CONTINUE C 110 CONTINUE C C ********** FOR I=LOW-1 STEP -1 UNTIL 1, C IGH+1 STEP 1 UNTIL N DO -- ********** 120 DO 140 II = 1, N I = II IF (I .GE. LOW .AND. I .LE. IGH) GO TO 140 IF (I .LT. LOW) I = LOW - II K = SCALE(I) IF (K .EQ. I) GO TO 140 C DO 130 J = 1, M S = ZR(I,J) ZR(I,J) = ZR(K,J) ZR(K,J) = S S = ZI(I,J) ZI(I,J) = ZI(K,J) ZI(K,J) = S 130 CONTINUE C 140 CONTINUE C 200 RETURN C ********** LAST CARD OF DCBABK ********** END SUBROUTINE DCMQR2 (NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR) C INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1, * ITS,LOW,LP1,ENM1,IEND,IERR DOUBLE PRECISION HR(NM,N),HI(NM,N),WR(N),WI(N),ZR(NM,N),ZI(NM,N), * ORTR(IGH),ORTI(IGH) DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,MACHEP DOUBLE PRECISION R2,W(2),Z(2) DOUBLE PRECISION DPMPAR,DCPABS C----------------------------------------------------------------------- C C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS C AND WILKINSON. C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971). C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM. C C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS OF C A DOUBLE PRECISION COMPLEX UPPER HESSENBERG MATRIX BY THE C QR METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX C CAN ALSO BE FOUND IF DCORTH HAS BEEN USED TO REDUCE C THIS GENERAL MATRIX TO HESSENBERG FORM. C C ON INPUT- C C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM C DIMENSION STATEMENT, C C N IS THE ORDER OF THE MATRIX, C C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING C SUBROUTINE DCBAL. IF DCBAL HAS NOT BEEN USED, C SET LOW=1, IGH=N, C C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS- C FORMATIONS USED IN THE REDUCTION BY DCORTH, IF PERFORMED. C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND C ORTI(J) TO 0.0 FOR THESE ELEMENTS, C C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX. C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE C REDUCTION BY DCORTH, IF PERFORMED. IF THE EIGENVECTORS OF C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE C ARBITRARY. C C ON OUTPUT- C C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI C HAVE BEEN DESTROYED, C C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT C FOR INDICES IERR+1,...,N, C C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS, C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF C THE EIGENVECTORS HAS BEEN FOUND, C C IERR IS SET TO C ZERO FOR NORMAL RETURN, C J IF THE J-TH EIGENVALUE HAS NOT BEEN C DETERMINED AFTER 50 ITERATIONS. C C----------------------------------------------------------------------- C C ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING C THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC. C MACHEP = DPMPAR(1) C C ********** C IERR = 0 C ********** INITIALIZE EIGENVECTOR MATRIX ********** DO 100 I = 1, N C DO 100 J = 1, N ZR(I,J) = 0.D0 ZI(I,J) = 0.D0 IF (I .EQ. J) ZR(I,J) = 1.D0 100 CONTINUE C ********** FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS C FROM THE INFORMATION LEFT BY DCORTH ********** IEND = IGH - LOW - 1 IF (IEND) 180, 150, 105 C ********** FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ********** 105 DO 140 II = 1, IEND I = IGH - II IF (ORTR(I) .EQ. 0.D0 .AND. ORTI(I) .EQ. 0.D0) GO TO 140 IF (HR(I,I-1) .EQ. 0.D0 .AND. HI(I,I-1) .EQ. 0.D0) GO TO 140 C ********** NORM BELOW IS NEGATIVE OF H FORMED IN DCORTH ********** NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I) IP1 = I + 1 C DO 110 K = IP1, IGH ORTR(K) = HR(K,I-1) ORTI(K) = HI(K,I-1) 110 CONTINUE C DO 130 J = I, IGH SR = 0.D0 SI = 0.D0 C DO 115 K = I, IGH SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J) SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J) 115 CONTINUE C SR = SR / NORM SI = SI / NORM C DO 120 K = I, IGH ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K) ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K) 120 CONTINUE C 130 CONTINUE C 140 CONTINUE C ********** CREATE REAL SUBDIAGONAL ELEMENTS ********** 150 L = LOW + 1 C DO 170 I = L, IGH LL = MIN0(I+1,IGH) IF (HI(I,I-1) .EQ. 0.D0) GO TO 170 NORM = DCPABS(HR(I,I-1),HI(I,I-1)) YR = HR(I,I-1) / NORM YI = HI(I,I-1) / NORM HR(I,I-1) = NORM HI(I,I-1) = 0.D0 C DO 155 J = I, N SI = YR * HI(I,J) - YI * HR(I,J) HR(I,J) = YR * HR(I,J) + YI * HI(I,J) HI(I,J) = SI 155 CONTINUE C DO 160 J = 1, LL SI = YR * HI(J,I) + YI * HR(J,I) HR(J,I) = YR * HR(J,I) - YI * HI(J,I) HI(J,I) = SI 160 CONTINUE C DO 165 J = LOW, IGH SI = YR * ZI(J,I) + YI * ZR(J,I) ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I) ZI(J,I) = SI 165 CONTINUE C 170 CONTINUE C ********** STORE ROOTS ISOLATED BY DCBAL ********** 180 DO 200 I = 1, N IF (I .GE. LOW .AND. I .LE. IGH) GO TO 200 WR(I) = HR(I,I) WI(I) = HI(I,I) 200 CONTINUE C EN = IGH TR = 0.D0 TI = 0.D0 C ********** SEARCH FOR NEXT EIGENVALUE ********** 220 IF (EN .LT. LOW) GO TO 680 ITS = 0 ENM1 = EN - 1 C ********** LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT C FOR L=EN STEP -1 UNTIL LOW DO -- ********** 240 DO 260 LL = LOW, EN L = EN + LOW - LL IF (L .EQ. LOW) GO TO 300 IF (DABS(HR(L,L-1)) .LE. X MACHEP * (DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1)) X + DABS(HR(L,L)) + DABS(HI(L,L)))) GO TO 300 260 CONTINUE C ********** FORM SHIFT ********** 300 IF (L .EQ. EN) GO TO 660 IF (ITS .EQ. 50) GO TO 1000 IF (ITS .EQ. 10 .OR. ITS .EQ. 20 .OR. ITS .EQ. 30) GO TO 320 SR = HR(EN,EN) SI = HI(EN,EN) XR = HR(ENM1,EN) * HR(EN,ENM1) XI = HI(ENM1,EN) * HR(EN,ENM1) IF (XR .EQ. 0.D0 .AND. XI .EQ. 0.D0) GO TO 340 YR = (HR(ENM1,ENM1) - SR) / 2.D0 YI = (HI(ENM1,ENM1) - SI) / 2.D0 Z(1) = YR*YR - YI*YI + XR Z(2) = 2.D0*YR*YI + XI CALL DCSQRT(Z,W) ZZR = W(1) ZZI = W(2) IF (YR * ZZR + YI * ZZI .GE. 0.D0) GO TO 310 ZZR = -ZZR ZZI = -ZZI 310 Z(1) = YR + ZZR Z(2) = YI + ZZI R2 = Z(1)**2 + Z(2)**2 SR = SR - (XR*Z(1) + XI*Z(2))/R2 SI = SI - (XI*Z(1) - XR*Z(2))/R2 GO TO 340 C ********** FORM EXCEPTIONAL SHIFT ********** 320 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2)) SI = 0.D0 C 340 DO 360 I = LOW, EN HR(I,I) = HR(I,I) - SR HI(I,I) = HI(I,I) - SI 360 CONTINUE C TR = TR + SR TI = TI + SI ITS = ITS + 1 C ********** REDUCE TO TRIANGLE (ROWS) ********** LP1 = L + 1 C DO 500 I = LP1, EN SR = HR(I,I-1) HR(I,I-1) = 0.D0 NORM = DSQRT(HR(I-1,I-1)*HR(I-1,I-1)+HI(I-1,I-1)*HI(I-1,I-1) X + SR*SR) XR = HR(I-1,I-1) / NORM WR(I-1) = XR XI = HI(I-1,I-1) / NORM WI(I-1) = XI HR(I-1,I-1) = NORM HI(I-1,I-1) = 0.D0 HI(I,I-1) = SR / NORM C DO 490 J = I, N YR = HR(I-1,J) YI = HI(I-1,J) ZZR = HR(I,J) ZZI = HI(I,J) HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI 490 CONTINUE C 500 CONTINUE C SI = HI(EN,EN) IF (SI .EQ. 0.D0) GO TO 540 NORM = DCPABS(HR(EN,EN),SI) SR = HR(EN,EN) / NORM SI = SI / NORM HR(EN,EN) = NORM HI(EN,EN) = 0.D0 IF (EN .EQ. N) GO TO 540 IP1 = EN + 1 C DO 520 J = IP1, N YR = HR(EN,J) YI = HI(EN,J) HR(EN,J) = SR * YR + SI * YI HI(EN,J) = SR * YI - SI * YR 520 CONTINUE C ********** INVERSE OPERATION (COLUMNS) ********** 540 DO 600 J = LP1, EN XR = WR(J-1) XI = WI(J-1) C DO 580 I = 1, J YR = HR(I,J-1) YI = 0.D0 ZZR = HR(I,J) ZZI = HI(I,J) IF (I .EQ. J) GO TO 560 YI = HI(I,J-1) HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI 560 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI 580 CONTINUE C DO 590 I = LOW, IGH YR = ZR(I,J-1) YI = ZI(I,J-1) ZZR = ZR(I,J) ZZI = ZI(I,J) ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI 590 CONTINUE C 600 CONTINUE C IF (SI .EQ. 0.D0) GO TO 240 C DO 630 I = 1, EN YR = HR(I,EN) YI = HI(I,EN) HR(I,EN) = SR * YR - SI * YI HI(I,EN) = SR * YI + SI * YR 630 CONTINUE C DO 640 I = LOW, IGH YR = ZR(I,EN) YI = ZI(I,EN) ZR(I,EN) = SR * YR - SI * YI ZI(I,EN) = SR * YI + SI * YR 640 CONTINUE C GO TO 240 C ********** A ROOT FOUND ********** 660 HR(EN,EN) = HR(EN,EN) + TR WR(EN) = HR(EN,EN) HI(EN,EN) = HI(EN,EN) + TI WI(EN) = HI(EN,EN) EN = ENM1 GO TO 220 C ********** ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND C VECTORS OF UPPER TRIANGULAR FORM ********** 680 NORM = 0.D0 C DO 720 I = 1, N C DO 720 J = I, N NORM = NORM + DABS(HR(I,J)) + DABS(HI(I,J)) 720 CONTINUE C IF (N .EQ. 1 .OR. NORM .EQ. 0.D0) GO TO 1001 C ********** FOR EN=N STEP -1 UNTIL 2 DO -- ********** DO 800 NN = 2, N EN = N + 2 - NN XR = WR(EN) XI = WI(EN) ENM1 = EN - 1 C ********** FOR I=EN-1 STEP -1 UNTIL 1 DO -- ********** DO 780 II = 1, ENM1 I = EN - II ZZR = HR(I,EN) ZZI = HI(I,EN) IF (I .EQ. ENM1) GO TO 760 IP1 = I + 1 C DO 740 J = IP1, ENM1 ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN) ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN) 740 CONTINUE C 760 YR = XR - WR(I) YI = XI - WI(I) IF (YR .EQ. 0.D0 .AND. YI .EQ. 0.D0) YR = MACHEP * NORM R2 = YR*YR + YI*YI HR(I,EN) = (ZZR*YR + ZZI*YI)/R2 HI(I,EN) = (ZZI*YR - ZZR*YI)/R2 780 CONTINUE C 800 CONTINUE C ********** END BACKSUBSTITUTION ********** ENM1 = N - 1 C ********** VECTORS OF ISOLATED ROOTS ********** DO 840 I = 1, ENM1 IF (I .GE. LOW .AND. I .LE. IGH) GO TO 840 IP1 = I + 1 C DO 820 J = IP1, N ZR(I,J) = HR(I,J) ZI(I,J) = HI(I,J) 820 CONTINUE C 840 CONTINUE C ********** MULTIPLY BY TRANSFORMATION MATRIX TO GIVE C VECTORS OF ORIGINAL FULL MATRIX. C FOR J=N STEP -1 UNTIL LOW+1 DO -- ********** DO 880 JJ = LOW, ENM1 J = N + LOW - JJ M = MIN0(J-1,IGH) C DO 880 I = LOW, IGH ZZR = ZR(I,J) ZZI = ZI(I,J) C DO 860 K = LOW, M ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J) ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J) 860 CONTINUE C ZR(I,J) = ZZR ZI(I,J) = ZZI 880 CONTINUE C GO TO 1001 C ********** SET ERROR -- NO CONVERGENCE TO AN C EIGENVALUE AFTER 50 ITERATIONS ********** 1000 IERR = EN 1001 RETURN C ********** LAST CARD OF DCMQR2 ********** END SUBROUTINE CL1(K, L, M, N, Q, KQ, KODE, TOLER, ITER, X, RES, * ERROR, WK, IWK) DIMENSION Q(KQ,*), X(*), RES(*), WK(*), IWK(*) C ------------------- KLM = K + L + M CALL XL1(K, L, M, N, KLM, KQ, KLM + N, N + 2, Q, KODE, TOLER, * ITER, X, RES, ERROR, WK, IWK(KLM+1), IWK(1)) RETURN END SUBROUTINE XL1(K, L, M, N, KLMD, KLM2D, NKLMD, N2D, * Q, KODE, TOLER, ITER, X, RES, ERROR, CU, IU, S) C C THIS SUBROUTINE USES A MODIFICATION OF THE SIMPLEX C METHOD OF LINEAR PROGRAMMING TO CALCULATE AN L1 SOLUTION C TO A K BY N SYSTEM OF LINEAR EQUATIONS C AX=B C SUBJECT TO L LINEAR EQUALITY CONSTRAINTS C CX=D C AND M LINEAR INEQUALITY CONSTRAINTS C EX.LE.F. C DESCRIPTION OF PARAMETERS C K NUMBER OF ROWS OF THE MATRIX A (K.GE.1). C L NUMBER OF ROWS OF THE MATRIX C (L.GE.0). C M NUMBER OF ROWS OF THE MATRIX E (M.GE.0). C N NUMBER OF COLUMNS OF THE MATRICES A,C,E (N.GE.1). C KLMD SET TO AT LEAST K+L+M FOR ADJUSTABLE DIMENSIONS. C KLM2D SET TO AT LEAST K+L+M+2 FOR ADJUSTABLE DIMENSIONS. C NKLMD SET TO AT LEAST N+K+L+M FOR ADJUSTABLE DIMENSIONS. C N2D SET TO AT LEAST N+2 FOR ADJUSTABLE DIMENSIONS C Q TWO DIMENSIONAL REAL ARRAY WITH KLM2D ROWS AND C AT LEAST N2D COLUMNS. C ON ENTRY THE MATRICES A,C AND E, AND THE VECTORS C B,D AND F MUST BE STORED IN THE FIRST K+L+M ROWS C AND N+1 COLUMNS OF Q AS FOLLOWS C A B C Q = C D C E F C THESE VALUES ARE DESTROYED BY THE SUBROUTINE. C KODE A CODE USED ON ENTRY TO, AND EXIT C FROM, THE SUBROUTINE. C ON ENTRY, THIS SHOULD NORMALLY BE SET TO 0. C HOWEVER, IF CERTAIN NONNEGATIVITY CONSTRAINTS C ARE TO BE INCLUDED IMPLICITLY, RATHER THAN C EXPLICITLY IN THE CONSTRAINTS EX.LE.F, THEN KODE C SHOULD BE SET TO 1, AND THE NONNEGATIVITY C CONSTRAINTS INCLUDED IN THE ARRAYS X AND C RES (SEE BELOW). C ON EXIT, KODE HAS ONE OF THE C FOLLOWING VALUES C 0- OPTIMAL SOLUTION FOUND, C 1- NO FEASIBLE SOLUTION TO THE C CONSTRAINTS, C 2- CALCULATIONS TERMINATED C PREMATURELY DUE TO ROUNDING ERRORS, C 3- MAXIMUM NUMBER OF ITERATIONS REACHED. C TOLER A SMALL POSITIVE TOLERANCE. EMPIRICAL C EVIDENCE SUGGESTS TOLER = 10**(-D*2/3), C WHERE D REPRESENTS THE NUMBER OF DECIMAL C DIGITS OF ACCURACY AVAILABLE. ESSENTIALLY, C THE SUBROUTINE CANNOT DISTINGUISH BETWEEN ZERO C AND ANY QUANTITY WHOSE MAGNITUDE DOES NOT EXCEED C TOLER. IN PARTICULAR, IT WILL NOT PIVOT ON ANY C NUMBER WHOSE MAGNITUDE DOES NOT EXCEED TOLER. C ITER ON ENTRY ITER MUST CONTAIN AN UPPER BOUND ON C THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C A SUGGESTED VALUE IS 10*(K+L+M). ON EXIT ITER C GIVES THE NUMBER OF SIMPLEX ITERATIONS. C X ONE DIMENSIONAL REAL ARRAY OF SIZE AT LEAST N2D. C ON EXIT THIS ARRAY CONTAINS A C SOLUTION TO THE L1 PROBLEM. IF KODE=1 C ON ENTRY, THIS ARRAY IS ALSO USED TO INCLUDE C SIMPLE NONNEGATIVITY CONSTRAINTS ON THE C VARIABLES. THE VALUES -1, 0, OR 1 C FOR X(J) INDICATE THAT THE J-TH VARIABLE C IS RESTRICTED TO BE .LE.0, UNRESTRICTED, C OR .GE.0 RESPECTIVELY. C RES ONE DIMENSIONAL REAL ARRAY OF SIZE AT LEAST KLMD. C ON EXIT THIS CONTAINS THE RESIDUALS B-AX C IN THE FIRST K COMPONENTS, D-CX IN THE C NEXT L COMPONENTS (THESE WILL BE =0),AND C F-EX IN THE NEXT M COMPONENTS. IF KODE=1 ON C ENTRY, THIS ARRAY IS ALSO USED TO INCLUDE SIMPLE C NONNEGATIVITY CONSTRAINTS ON THE RESIDUALS C B-AX. THE VALUES -1, 0, OR 1 FOR RES(I) C INDICATE THAT THE I-TH RESIDUAL (1.LE.I.LE.K) IS C RESTRICTED TO BE .LE.0, UNRESTRICTED, OR .GE.0 C RESPECTIVELY. C ERROR ON EXIT, THIS GIVES THE MINIMUM SUM OF C ABSOLUTE VALUES OF THE RESIDUALS. C CU A TWO DIMENSIONAL REAL ARRAY WITH TWO ROWS AND C AT LEAST NKLMD COLUMNS USED FOR WORKSPACE. C IU A TWO DIMENSIONAL INTEGER ARRAY WITH TWO ROWS AND C AT LEAST NKLMD COLUMNS USED FOR WORKSPACE. C S INTEGER ARRAY OF SIZE AT LEAST KLMD, USED FOR C WORKSPACE. C IF YOUR FORTRAN COMPILER PERMITS A SINGLE COLUMN OF A TWO C DIMENSIONAL ARRAY TO BE PASSED TO A ONE DIMENSIONAL ARRAY C THROUGH A SUBROUTINE CALL, CONSIDERABLE SAVINGS IN C EXECUTION TIME MAY BE ACHIEVED THROUGH THE USE OF THE C FOLLOWING SUBROUTINE, WHICH OPERATES ON COLUMN VECTORS. C SUBROUTINE COL(V1, V2, XMLT, NOTROW, K) C THIS SUBROUTINE ADDS TO THE VECTOR V1 A MULTIPLE OF THE C VECTOR V2 (ELEMENTS 1 THROUGH K EXCLUDING NOTROW). C DIMENSION V1(K), V2(K) C KEND = NOTROW - 1 C KSTART = NOTROW + 1 C IF (KEND .LT. 1) GO TO 20 C DO 10 I=1,KEND C V1(I) = V1(I) + XMLT*V2(I) C 10 CONTINUE C IF(KSTART .GT. K) GO TO 40 C 20 DO 30 I=KSTART,K C V1(I) = V1(I) + XMLT*V2(I) C 30 CONTINUE C 40 RETURN C END C SEE COMMENTS FOLLOWING STATEMENT LABELLED 440 FOR C INSTRUCTIONS ON THE IMPLEMENTATION OF THIS MODIFICATION. C DOUBLE PRECISION SUM REAL Q, X, Z, CU, SN, ZU, ZV, CUV, RES, XMAX, XMIN, * ERROR, PIVOT, TOLER, TPIVOT INTEGER I, J, K, L, M, N, S, IA, II, IN, IU, JS, KK, * NK, N1, N2, JMN, JPN, KLM, NKL, NK1, N2D, IIMN, * IOUT, ITER, KLMD, KLM1, KLM2, KODE, NKLM, NKL1, * KLM2D, MAXIT, NKLMD, IPHASE, KFORCE, IINEG DIMENSION Q(KLM2D,N2D), X(N2D), RES(KLMD), * CU(2,NKLMD), IU(2,NKLMD), S(KLMD) C C INITIALIZATION. C MAXIT = ITER N1 = N + 1 N2 = N + 2 NK = N + K NK1 = NK + 1 NKL = NK + L NKL1 = NKL + 1 KLM = K + L + M KLM1 = KLM + 1 KLM2 = KLM + 2 NKLM = N + KLM KFORCE = 1 ITER = 0 JS = 1 IA = 0 C SET UP LABELS IN Q. DO 10 J=1,N Q(KLM2,J) = J 10 CONTINUE DO 30 I=1,KLM Q(I,N2) = N + I IF (Q(I,N1).GE.0.) GO TO 30 DO 20 J=1,N2 Q(I,J) = -Q(I,J) 20 CONTINUE 30 CONTINUE C SET UP PHASE 1 COSTS. IPHASE = 2 DO 40 J=1,NKLM CU(1,J) = 0. CU(2,J) = 0. IU(1,J) = 0 IU(2,J) = 0 40 CONTINUE IF (L.EQ.0) GO TO 60 DO 50 J=NK1,NKL CU(1,J) = 1. CU(2,J) = 1. IU(1,J) = 1 IU(2,J) = 1 50 CONTINUE IPHASE = 1 60 IF (M.EQ.0) GO TO 80 DO 70 J=NKL1,NKLM CU(2,J) = 1. IU(2,J) = 1 JMN = J - N IF (Q(JMN,N2).LT.0.) IPHASE = 1 70 CONTINUE 80 IF (KODE.EQ.0) GO TO 150 DO 110 J=1,N IF (X(J)) 90, 110, 100 90 CU(1,J) = 1. IU(1,J) = 1 GO TO 110 100 CU(2,J) = 1. IU(2,J) = 1 110 CONTINUE DO 140 J=1,K JPN = J + N IF (RES(J)) 120, 140, 130 120 CU(1,JPN) = 1. IU(1,JPN) = 1 IF (Q(J,N2).GT.0.0) IPHASE = 1 GO TO 140 130 CU(2,JPN) = 1. IU(2,JPN) = 1 IF (Q(J,N2).LT.0.0) IPHASE = 1 140 CONTINUE 150 IF (IPHASE.EQ.2) GO TO 500 C COMPUTE THE MARGINAL COSTS. 160 DO 200 J=JS,N1 SUM = 0.D0 DO 190 I=1,KLM II = Q(I,N2) IF (II.LT.0) GO TO 170 Z = CU(1,II) GO TO 180 170 IINEG = -II Z = CU(2,IINEG) 180 SUM = SUM + DBLE(Q(I,J))*DBLE(Z) 190 CONTINUE Q(KLM1,J) = SUM 200 CONTINUE DO 230 J=JS,N II = Q(KLM2,J) IF (II.LT.0) GO TO 210 Z = CU(1,II) GO TO 220 210 IINEG = -II Z = CU(2,IINEG) 220 Q(KLM1,J) = Q(KLM1,J) - Z 230 CONTINUE C DETERMINE THE VECTOR TO ENTER THE BASIS. 240 XMAX = 0. IF (JS.GT.N) GO TO 490 DO 280 J=JS,N ZU = Q(KLM1,J) II = Q(KLM2,J) IF (II.GT.0) GO TO 250 II = -II ZV = ZU ZU = -ZU - CU(1,II) - CU(2,II) GO TO 260 250 ZV = -ZU - CU(1,II) - CU(2,II) 260 IF (KFORCE.EQ.1 .AND. II.GT.N) GO TO 280 IF (IU(1,II).EQ.1) GO TO 270 IF (ZU.LE.XMAX) GO TO 270 XMAX = ZU IN = J 270 IF (IU(2,II).EQ.1) GO TO 280 IF (ZV.LE.XMAX) GO TO 280 XMAX = ZV IN = J 280 CONTINUE IF (XMAX.LE.TOLER) GO TO 490 IF (Q(KLM1,IN).EQ.XMAX) GO TO 300 DO 290 I=1,KLM2 Q(I,IN) = -Q(I,IN) 290 CONTINUE Q(KLM1,IN) = XMAX C DETERMINE THE VECTOR TO LEAVE THE BASIS. 300 IF (IPHASE.EQ.1 .OR. IA.EQ.0) GO TO 330 XMAX = 0. DO 310 I=1,IA Z = ABS(Q(I,IN)) IF (Z.LE.XMAX) GO TO 310 XMAX = Z IOUT = I 310 CONTINUE IF (XMAX.LE.TOLER) GO TO 330 DO 320 J=1,N2 Z = Q(IA,J) Q(IA,J) = Q(IOUT,J) Q(IOUT,J) = Z 320 CONTINUE IOUT = IA IA = IA - 1 PIVOT = Q(IOUT,IN) GO TO 420 330 KK = 0 DO 340 I=1,KLM Z = Q(I,IN) IF (Z.LE.TOLER) GO TO 340 KK = KK + 1 RES(KK) = Q(I,N1)/Z S(KK) = I 340 CONTINUE 350 IF (KK.GT.0) GO TO 360 KODE = 2 GO TO 590 360 XMIN = RES(1) IOUT = S(1) J = 1 IF (KK.EQ.1) GO TO 380 DO 370 I=2,KK IF (RES(I).GE.XMIN) GO TO 370 J = I XMIN = RES(I) IOUT = S(I) 370 CONTINUE RES(J) = RES(KK) S(J) = S(KK) 380 KK = KK - 1 PIVOT = Q(IOUT,IN) II = Q(IOUT,N2) IF (IPHASE.EQ.1) GO TO 400 IF (II.LT.0) GO TO 390 IF (IU(2,II).EQ.1) GO TO 420 GO TO 400 390 IINEG = -II IF (IU(1,IINEG).EQ.1) GO TO 420 400 II = IABS(II) CUV = CU(1,II) + CU(2,II) IF (Q(KLM1,IN)-PIVOT*CUV.LE.TOLER) GO TO 420 C BYPASS INTERMEDIATE VERTICES. DO 410 J=JS,N1 Z = Q(IOUT,J) Q(KLM1,J) = Q(KLM1,J) - Z*CUV Q(IOUT,J) = -Z 410 CONTINUE Q(IOUT,N2) = -Q(IOUT,N2) GO TO 350 C GAUSS-JORDAN ELIMINATION. 420 IF (ITER.LT.MAXIT) GO TO 430 KODE = 3 GO TO 590 430 ITER = ITER + 1 DO 440 J=JS,N1 IF (J.NE.IN) Q(IOUT,J) = Q(IOUT,J)/PIVOT 440 CONTINUE C IF PERMITTED, USE SUBROUTINE COL OF THE DESCRIPTION C SECTION AND REPLACE THE FOLLOWING SEVEN STATEMENTS DOWN C TO AND INCLUDING STATEMENT NUMBER 460 BY.. C DO 460 J=JS,N1 C IF(J .EQ. IN) GO TO 460 C Z = -Q(IOUT,J) C CALL COL(Q(1,J), Q(1,IN), Z, IOUT, KLM1) C 460 CONTINUE DO 460 J=JS,N1 IF (J.EQ.IN) GO TO 460 Z = -Q(IOUT,J) DO 450 I=1,KLM1 IF (I.NE.IOUT) Q(I,J) = Q(I,J) + Z*Q(I,IN) 450 CONTINUE 460 CONTINUE TPIVOT = -PIVOT DO 470 I=1,KLM1 IF (I.NE.IOUT) Q(I,IN) = Q(I,IN)/TPIVOT 470 CONTINUE Q(IOUT,IN) = 1./PIVOT Z = Q(IOUT,N2) Q(IOUT,N2) = Q(KLM2,IN) Q(KLM2,IN) = Z II = ABS(Z) IF (IU(1,II).EQ.0 .OR. IU(2,II).EQ.0) GO TO 240 DO 480 I=1,KLM2 Z = Q(I,IN) Q(I,IN) = Q(I,JS) Q(I,JS) = Z 480 CONTINUE JS = JS + 1 GO TO 240 C TEST FOR OPTIMALITY. 490 IF (KFORCE.EQ.0) GO TO 580 IF (IPHASE.EQ.1 .AND. Q(KLM1,N1).LE.TOLER) GO TO 500 KFORCE = 0 GO TO 240 C SET UP PHASE 2 COSTS. 500 IPHASE = 2 DO 510 J=1,NKLM CU(1,J) = 0. CU(2,J) = 0. 510 CONTINUE DO 520 J=N1,NK CU(1,J) = 1. CU(2,J) = 1. 520 CONTINUE DO 560 I=1,KLM II = Q(I,N2) IF (II.GT.0) GO TO 530 II = -II IF (IU(2,II).EQ.0) GO TO 560 CU(2,II) = 0. GO TO 540 530 IF (IU(1,II).EQ.0) GO TO 560 CU(1,II) = 0. 540 IA = IA + 1 DO 550 J=1,N2 Z = Q(IA,J) Q(IA,J) = Q(I,J) Q(I,J) = Z 550 CONTINUE 560 CONTINUE GO TO 160 570 IF (Q(KLM1,N1).LE.TOLER) GO TO 500 KODE = 1 GO TO 590 580 IF (IPHASE.EQ.1) GO TO 570 C PREPARE OUTPUT. KODE = 0 590 SUM = 0.D0 DO 600 J=1,N X(J) = 0. 600 CONTINUE DO 610 I=1,KLM RES(I) = 0. 610 CONTINUE DO 640 I=1,KLM II = Q(I,N2) SN = 1. IF (II.GT.0) GO TO 620 II = -II SN = -1. 620 IF (II.GT.N) GO TO 630 X(II) = SN*Q(I,N1) GO TO 640 630 IIMN = II - N RES(IIMN) = SN*Q(I,N1) IF (II.GE.N1 .AND. II.LE.NK) SUM = SUM + * DBLE(Q(I,N1)) 640 CONTINUE ERROR = SUM RETURN END SUBROUTINE LLSQ(M,N,A,KA,B,KB,NB,WK,IWK,IERR) DIMENSION A(KA,N),B(KB,NB),WK(N),IWK(N) LOGICAL EXIT C -------------- IERR = 0 IF (1 .LT. N .AND. N .LE. M) GO TO 10 IERR = 1 RETURN C 10 NP1 = N + 1 CALL ORTHO(M,N,A,KA,WK,IWK,EXIT) IF (EXIT) GO TO 20 IERR = 2 RETURN C 20 DO 22 J = 1,NB CALL ORSOL(M,N,A,KA,WK,IWK,B(1,J)) IF (M .EQ. N) GO TO 22 RNORM = 0.0 DO 21 I = NP1,M 21 RNORM = RNORM + B(I,J)*B(I,J) B(NP1,J) = SQRT(RNORM) 22 CONTINUE RETURN END SUBROUTINE LLSQMP(M,N,A,KA,B,KB,NB,WK,IWK,IERR) DIMENSION A(KA,N),B(KB,NB),WK(*),IWK(N) LOGICAL EXIT C ------------------- C DIMENSION WK(MN + 2M + N) C ------------------- IERR = 0 IF (1.LT.N .AND. N.LE.M) GO TO 10 IERR = 2 RETURN C 10 NP1 = N + 1 LR = M + 1 LS = LR + M LQ = LS + N C CALL MCOPY(M, N, A, KA, WK(LQ), M) CALL ORTHO(M, N, WK(LQ), M, WK(LS), IWK, EXIT) IF (EXIT) GO TO 20 IERR = 3 RETURN C 20 DO 31 J = 1,NB DO 21 I = 1,M 21 WK(I) = B(I,J) CALL ORSOL(M, N, WK(LQ), M, WK(LS), IWK, WK(1)) CALL ORIMP(M, N, A, KA, WK(LQ), M, WK(LS), IWK, B(1,J), * WK(1), WK(LR), EXIT) DO 22 I = 1,N 22 B(I,J) = WK(I) IF (.NOT.EXIT) IERR = 1 IF (M .EQ. N) GO TO 31 C RNORM = 0.0 DO 30 I = NP1,M 30 RNORM = RNORM + WK(I)*WK(I) B(NP1,J) = SQRT(RNORM) 31 CONTINUE RETURN END SUBROUTINE ORTHO(M, N, QR, MS, S, IP, EXIT) C*********************************************************************** C IDENTIFICATION C ORTHO - ORTHOGONAL TRANSFORMATION OF A GIVEN GENERAL M BY N C MATRIX A TO UPPER TRIANGULAR FORM C FORTRAN SUBROUTINE SUBPROGRAM C AEROSPACE RESEARCH LABORATORIES C WRIGHT-PATTERSON AFB, OHIO 45433 C PURPOSE C ORTHO COMPUTES AN IMPLICIT ORTHOGONAL MATRIX Q AND AN EXPLICIT C UPPER TRIANGULAR MATRIX R AND A PERMUTATION MATRIX P SATISFYING C QR = PA GIVEN AN M BY N REAL MATRIX A. ORTHO IS INTENDED FOR C USE WITH THE SUBROUTINE ORSOL TO PRODUCE THE LEAST SQUARES C SOLUTION OF THE EQUATION AX = B. C CONTROL C C DIMENSION QR(MS,N), S(N), IP(N) C LOGICAL EXIT C . C . C . C CALL ORTHO(M, N, QR, MS, S, IP, EXIT) C C WHERE C M IS AN INTEGER INPUT VARIABLE, THE NUMBER OF ROWS OF A. C N IS AN INTEGER INPUT VARIABLE, THE NUMBER OF COLUMNS OF A, C (1 .LT. N .LE. M). C QR AS A REAL INPUT ARRAY IS MATRIX A TO BE TRIANGULARIZED. C QR AS A REAL OUTPUT ARRAY IS THE UPPER TRIANGULAR FACTOR R IN C QR(I,J), I .LE. J, AND THE RELEVANT PARTS OF Q IN QR(I,J), C I .GT. J. C MS IS AN INTEGER INPUT VARIABLE, THE LEADING DIMENSION OF C QR IN THE CALLING PROGRAM. C S IS A REAL OUTPUT ARRAY, THE RELEVANT PARTS OF Q. C IP IS AN INTEGER OUTPUT ARRAY CONTAINING IN IP(I), I=1,...,N, C THE IMAGES OF THE PERMUTATION CORRESPONDING TO THE PERMU- C TATION MATRIX P. C EXIT IS SET TO THE VALUE .TRUE. IF THE RANK OF A IS EQUAL TO N C AND .FALSE. OTHERWISE. C METHOD C THE MATRIX A IN THE ARRAY QR IS REDUCED TO UPPER TRIANGULAR C FORM USING ORTHOGONAL TRANSFORMATION WITH PARTIAL PIVOTING. C REFERENCES C (1) PETER BUSINGER AND G.H. GOLUB, LINEAR LEAST SQUARES SOLU- C TIONS BY HOUSEHOLDER TRANSFORMATIONS, NUMER. MATH. 7(1965), C 269-276. C (2) N.K. TSAO AND P.J. NIKOLAI, PROCEDURES USING ORTHOGONAL C TRANSFORMATIONS FOR LINEAR LEAST SQUARES PROBLEMS, ARL C TECHNICAL REPORT ARL TR 74-0124(1974). C*********************************************************************** DIMENSION QR(MS,N), S(N), IP(N) LOGICAL EXIT C EXIT = .TRUE. NN = N IF (N .EQ. M) NN = N - 1 DO 80 J = 1, NN IP(J) = J JP = J + 1 KJ = J C SEARCH FOR PIVOT IN THE J-TH C COLUMN AND INTERCHANGE ROWS. DO 10 K = JP, M IF (ABS(QR(K,J)) .GT. ABS(QR(KJ,J))) KJ = K 10 CONTINUE IF (QR(KJ,J) .EQ. 0.0) GO TO 90 IF (KJ .EQ. J) GO TO 30 IP(J) = KJ DO 20 I = J, N SAV = QR(J,I) QR(J,I) = QR(KJ,I) 20 QR(KJ,I) = SAV C NORMALIZE THE PIVOTING COLUMN C AND FIND ITS NORM. 30 AJJ = QR(J,J) DO 31 I = JP, M 31 QR(I,J) = QR(I,J)/AJJ SAV = 1.0 DO 40 I = JP, M 40 SAV = SAV + QR(I,J)*QR(I,J) S(J) = -SQRT(SAV) QR(J,J) = S(J)*AJJ IF (JP .GT. N) GO TO 80 C PREMULTIPLY QR WITH THE J-TH C ORTHOGONAL MATRIX. Y = 1.0 - S(J) DO 70 K = JP, N SAV = QR(J,K) DO 50 I = JP, M 50 SAV = SAV + QR(I,J)*QR(I,K) SS = QR(J,K) QR(J,K) = SAV/S(J) SS = (SS - QR(J,K))/Y DO 60 I = JP, M 60 QR(I,K) = QR(I,K) - QR(I,J)*SS 70 CONTINUE 80 CONTINUE RETURN C 90 EXIT = .FALSE. RETURN END SUBROUTINE ORSOL(M, N, QR, MS, S, IP, X) C*********************************************************************** C IDENTIFICATION C ORSOL - LEAST SQUARES SOLUTION OF A LINEAR SYSTEM GIVEN AN C ORTHOGONAL-TRIANGULAR FACTORIZATION OF THE COEFFICIENT C MATRIX PRODUCED BY SUBROUTINE ORTHO C FORTRAN SUBROUTINE SUBPROGRAM C AEROSPACE RESEARCH LABORATORIES C WRIGHT-PATTERSON AFB, OHIO 45433 C PURPOSE C ORSOL COMPUTES THE LEAST SQUARES SOLUTION OF THE LINEAR SYSTEM C QRX = PAX = B WHERE Q, R, AND P ARE DETERMINED FROM A BY ORTHO. C CONTROL C C DIMENSION QR(MS,N), S(N), IP(N), X(M) C . C . C . C CALL ORSOL(M, N, QR, MS, S, IP, X) C C WHERE C M IS AN INTEGER INPUT VARIABLE, THE NUMBER OF ROWS OF A. C N IS AN INTEGER INPUT VARIABLE, THE NUMBER OF COLUMNS OF A C (1 .LT. N .LE. M). C QR IS A REAL INPUT ARRAY, THE ORTHOGONAL AND TRIANGULAR FACTORS C OF A PRODUCED BY ORTHO. C MS IS AN INTEGER INPUT VARIABLE, THE LEADING DIMENSION OF C QR IN THE CALLING PROGRAM. C S IS A REAL INPUT ARRAY, THE RELEVANT PARTS OF Q PRODUCED BY C ORTHO. C IP IS AN INTEGER INPUT ARRAY, THE PERMUTATION INFORMATION C PRODUCED BY ORTHO. C X AS A REAL INPUT ARRAY IS THE RIGHT-HAND SIDE B OF AX = B. C X AS A REAL OUTPUT ARRAY IS X(I), I = 1, ..., N, THE LEAST C SQUARES SOLUTION, AND X(J), J = N+1, ..., M, THE VECTOR C WHOSE LENGTH IS THE MINIMUM OF ALL RESIDUAL B - AX. C METHOD C THE FACTORED SYSTEM QRX = PAX = PB ARE SOLVED IN THE SEQUENCE C OF QY = PB AND RX = Y. FULL RANK FOR THE MATRIX A IS ASSUMED C WHICH CAN BE CHECKED BY INTERROGATING THE LOGICAL OUTPUT C VARIABLE PRODUCED BY ORTHO. C REFERENCES C (1) PETER BUSINGER AND G.H. GOLUB, LINEAR LEAST SQUARES SOLU- C TIONS BY HOUSEHOLDER TRANSFORMATIONS, NUMER. MATH. 7(1965), C 269-276. C (2) N.K. TSAO AND P.J. NIKOLAI, PROCEDURES USING ORTHOGONAL C TRANSFORMATIONS FOR LINEAR LEAST SQUARES PROBLEMS, ARL C TECHNICAL REPORT ARL TR 74-0124(1974). C*********************************************************************** DIMENSION QR(MS,N), S(N), IP(N), X(M) C NN = N IF (N .EQ. M) NN = N - 1 DO 30 J = 1, NN JP = J + 1 IJ = IP(J) Y = 1.0 - S(J) SAV = X(J) X(J) = X(IJ) X(IJ) = SAV C PREMULTIPLY X WITH THE J-TH C ORTHOGONAL MATRIX. SAV = X(J) DO 10 K = JP, M 10 SAV = SAV + QR(K,J)*X(K) SS = X(J) X(J) = SAV/S(J) SS = (SS - X(J))/Y DO 20 K = JP, M 20 X(K) = X(K) - QR(K,J)*SS 30 CONTINUE C BACK SUBSTITUTE TO FIND THE C LEAST SQUARES SOLUTION. X(N) = X(N)/QR(N,N) NM = N - 1 DO 50 I = 1, NM NI = N - I NN = N DO 40 J = 1, I X(NI) = X(NI) - QR(NI,NN)*X(NN) 40 NN = NN - 1 X(NI) = X(NI)/QR(NI,NI) 50 CONTINUE RETURN END SUBROUTINE ORIMP(M, N, A, KA, QR, MS, S, IP, B, X, R, EXIT) C ---------------------------------------------------------------------- C PURPOSE C GIVEN AN APPROXIMATE LEAST SQUARES SOLUTION X OF A LINEAR C SYSTEM AX = B OBTAINED USING ORSOL. ORIMP ATTEMPTS TO COMPUTE C AN IMPROVED SOLUTION CORRECT TO MACHINE PRECISION. C C CONTROL C C DIMENSION A(KA,N), QR(MS,N), B(M), X(M), R(M), S(N), IP(N) C LOGICAL EXIT C . C . C . C CALL ORIMP(M, N, A, KA, QR, MS, S, IP, B, X, R, EXIT) C C WHERE C M IS AN INTEGER INPUT VARIABLE, THE NUMBER OF ROWS OF A. C N IS AN INTEGER INPUT VARIABLE, THE NUMBER OF COLUMNS OF A C (1 .LT. N .LE. M). C A IS A REAL INPUT ARRAY, THE GIVEN M BY N MATRIX. C QR IS A REAL INPUT ARRAY, THE ORTHOGONAL AND TRIANGULAR C FACTORS OF A PRODUCED BY ORTHO. C B IS A REAL INPUT ARRAY, THE RIGHT HAND SIDE OF AX = B. C X AS A REAL INPUT ARRAY IS THE APPROXIMATE LEAST SQUARES C SOLUTION TOGETHER WITH THE RESIDUAL INFORMATION PRODUCED C BY ORSOL. C X AS A REAL OUTPUT ARRAY IS THE IMPROVED LEAST SQUARES C SOLUTION WITH A RESIDUAL OF MINIMUM LENGTH. C R IS A REAL OUTPUT ARRAY, THE CORRECTION VECTOR ADDED TO X. C KA IS AN INTEGER INPUT VARIABLE, THE LEADING DIMENSION OF C OF A IN THE CALLING PROGRAM. C MS IS AN INTEGER INPUT VARIABLE, THE LEADING DIMENSION OF C OF QR IN THE CALLING PROGRAM. C S IS A REAL INPUT ARRAY, A RELEVANT PART OF Q PRODUCED BY C ORTHO. C IP IS AN INTEGER INPUT ARRAY, THE PERMUTATION INFORMATION C PRODUCED BY ORTHO. C EXIT IS SET TO THE VALUE .TRUE. IF IMPROVEMENT OF X IS SUCCESS- C FUL WITH A GAIN IN ACCURACY OF AT LEAST 50 PER CENT EACH C ITERATION AND .FALSE. OTHERWISE. C C METHOD C ORIMP EXECUTES THE ITERATION CYCLE C (1) AR = B - AX C (2) X = X + R C WITH A GIVEN INITIAL X. THE RESIDUAL VECTOR B - AX IS COMPUTED C TO HIGH ACCURACY BY DOUBLE PRECISION. ORSOL IS THEN USED TO C SOLVE (1). C C ---------------------------------------------------------------------- C DIMENSION A(KA,N), QR(MS,N), B(M), X(M), R(M), S(N), IP(N) LOGICAL EXIT DOUBLE PRECISION DSUM DATA ZERO/0.0/, ONE/1.0/, FOUR/4.0/, FOURTH/0.25/ C C ********** EPS IS A MACHINE DEPENDENT PARAMETER. ASSIGN EPS C THE VALUE U WHERE U IS THE SMALLEST POSITIVE FLOATING C POINT NUMBER SUCH THAT 1.0 + U .GT. 1.0. C EPS = SPMPAR(1) C EXIT = .TRUE. NP1 = N + 1 EPS2 = EPS*EPS C XNRM2 = ZERO DO 10 I = 1,N 10 XNRM2 = XNRM2 + X(I)*X(I) IF (XNRM2 .EQ. ZERO) RETURN RATIO = ONE C C FIND THE RESIDUAL VECTOR. C 20 DO 22 K = 1,M DSUM = B(K) DO 21 J = 1,N 21 DSUM = DSUM - DBLE(A(K,J))*DBLE(X(J)) 22 R(K) = DSUM C C FIND THE CORRECTION VECTOR. C CALL ORSOL(M, N, QR, MS, S, IP, R) RNRM2 = ZERO DO 30 K = 1,N 30 RNRM2 = RNRM2 + R(K)*R(K) IF (RNRM2 .LE. EPS2*XNRM2) RETURN C C FORM NEW APPROXIMATE SOLUTION. C DO 40 K = 1,N 40 X(K) = X(K) + R(K) XNRM2 = ZERO DO 41 K = 1,N 41 XNRM2 = XNRM2 + X(K)*X(K) IF (M .EQ. N) GO TO 50 DO 42 K = NP1,M 42 X(K) = R(K) C 50 IF (XNRM2 .EQ. ZERO) RETURN RAT = RATIO RATIO = RNRM2/XNRM2 IF (RATIO .LE. FOURTH*RAT) GO TO 20 C IF (RATIO .LE. AMIN1(RAT,FOUR*EPS2)) RETURN EXIT = .FALSE. RETURN END SUBROUTINE DLLSQ(M,N,A,KA,B,KB,NB,WK,IWK,IERR) DOUBLE PRECISION A(KA,N),B(KB,NB),WK(N) INTEGER IWK(N) DOUBLE PRECISION RNORM LOGICAL EXIT C -------------- IERR = 0 IF (1 .LT. N .AND. N .LE. M) GO TO 10 IERR = 1 RETURN C 10 NP1 = N + 1 CALL DORTHO(M,N,A,KA,WK,IWK,EXIT) IF (EXIT) GO TO 20 IERR = 2 RETURN C 20 DO 22 J = 1,NB CALL DORSOL(M,N,A,KA,WK,IWK,B(1,J)) IF (M .EQ. N) GO TO 22 RNORM = 0.D0 DO 21 I = NP1,M 21 RNORM = RNORM + B(I,J)*B(I,J) B(NP1,J) = DSQRT(RNORM) 22 CONTINUE RETURN END SUBROUTINE DORTHO(M, N, QR, MS, S, IP, EXIT) C*********************************************************************** C IDENTIFICATION C DORTHO - ORTHOGONAL TRANSFORMATION OF A GIVEN GENERAL M BY N C MATRIX A TO UPPER TRIANGULAR FORM C FORTRAN SUBROUTINE SUBPROGRAM C AEROSPACE RESEARCH LABORATORIES C WRIGHT-PATTERSON AFB, OHIO 45433 C PURPOSE C DORTHO COMPUTES AN IMPLICIT ORTHOGONAL MATRIX Q AND AN EXPLICIT C UPPER TRIANGULAR MATRIX R AND A PERMUTATION MATRIX P SATISFYING C QR = PA GIVEN AN M BY N REAL MATRIX A. DORTHO IS INTENDED FOR C USE WITH THE SUBROUTINE DORSOL TO PRODUCE THE LEAST SQUARES C SOLUTION OF THE EQUATION AX = B. C CONTROL C C DIMENSION QR(MS,N), S(N), IP(N) C LOGICAL EXIT C . C . C . C CALL DORTHO(M, N, QR, MS, S, IP, EXIT) C C WHERE C M IS AN INTEGER INPUT VARIABLE, THE NUMBER OF ROWS OF A. C N IS AN INTEGER INPUT VARIABLE, THE NUMBER OF COLUMNS OF A, C (1 .LT. N .LE. M). C QR AS A REAL INPUT ARRAY IS MATRIX A TO BE TRIANGULARIZED. C QR AS A REAL OUTPUT ARRAY IS THE UPPER TRIANGULAR FACTOR R IN C QR(I,J), I .LE. J, AND THE RELEVANT PARTS OF Q IN QR(I,J), C I .GT. J. C MS IS AN INTEGER INPUT VARIABLE, THE LEADING DIMENSION OF C QR IN THE CALLING PROGRAM. C S IS A REAL OUTPUT ARRAY, THE RELEVANT PARTS OF Q. C IP IS AN INTEGER OUTPUT ARRAY CONTAINING IN IP(I), I=1,...,N, C THE IMAGES OF THE PERMUTATION CORRESPONDING TO THE PERMU- C TATION MATRIX P. C EXIT IS SET TO THE VALUE .TRUE. IF THE RANK OF A IS EQUAL TO N C AND .FALSE. OTHERWISE. C METHOD C THE MATRIX A IN THE ARRAY QR IS REDUCED TO UPPER TRIANGULAR C FORM USING ORTHOGONAL TRANSFORMATION WITH PARTIAL PIVOTING. C REFERENCES C (1) PETER BUSINGER AND G.H. GOLUB, LINEAR LEAST SQUARES SOLU- C TIONS BY HOUSEHOLDER TRANSFORMATIONS, NUMER. MATH. 7(1965), C 269-276. C (2) N.K. TSAO AND P.J. NIKOLAI, PROCEDURES USING ORTHOGONAL C TRANSFORMATIONS FOR LINEAR LEAST SQUARES PROBLEMS, ARL C TECHNICAL REPORT ARL TR 74-0124(1974). C*********************************************************************** DOUBLE PRECISION QR(MS,N), S(N) INTEGER IP(N) DOUBLE PRECISION AJJ, SAV, SS, Y LOGICAL EXIT C EXIT = .TRUE. NN = N IF (N .EQ. M) NN = N - 1 DO 80 J = 1, NN IP(J) = J JP = J + 1 KJ = J C SEARCH FOR PIVOT IN THE J-TH C COLUMN AND INTERCHANGE ROWS. DO 10 K = JP, M IF (DABS(QR(K,J)) .GT. DABS(QR(KJ,J))) KJ = K 10 CONTINUE IF (QR(KJ,J) .EQ. 0.D0) GO TO 90 IF (KJ .EQ. J) GO TO 30 IP(J) = KJ DO 20 I = J, N SAV = QR(J,I) QR(J,I) = QR(KJ,I) 20 QR(KJ,I) = SAV C NORMALIZE THE PIVOTING COLUMN C AND FIND ITS NORM. 30 AJJ = QR(J,J) DO 31 I = JP, M 31 QR(I,J) = QR(I,J)/AJJ SAV = 1.D0 DO 40 I = JP, M 40 SAV = SAV + QR(I,J)*QR(I,J) S(J) = -DSQRT(SAV) QR(J,J) = S(J)*AJJ IF (JP .GT. N) GO TO 80 C PREMULTIPLY QR WITH THE J-TH C ORTHOGONAL MATRIX. Y = 1.D0 - S(J) DO 70 K = JP, N SAV = QR(J,K) DO 50 I = JP, M 50 SAV = SAV + QR(I,J)*QR(I,K) SS = QR(J,K) QR(J,K) = SAV/S(J) SS = (SS - QR(J,K))/Y DO 60 I = JP, M 60 QR(I,K) = QR(I,K) - QR(I,J)*SS 70 CONTINUE 80 CONTINUE RETURN C 90 EXIT = .FALSE. RETURN END SUBROUTINE DORSOL(M, N, QR, MS, S, IP, X) C*********************************************************************** C IDENTIFICATION C DORSOL - LEAST SQUARES SOLUTION OF A LINEAR SYSTEM GIVEN AN C ORTHOGONAL-TRIANGULAR FACTORIZATION OF THE COEFFICIENT C MATRIX PRODUCED BY SUBROUTINE DORTHO C FORTRAN SUBROUTINE SUBPROGRAM C AEROSPACE RESEARCH LABORATORIES C WRIGHT-PATTERSON AFB, OHIO 45433 C PURPOSE C DORSOL COMPUTES THE LEAST SQUARES SOLUTION OF THE LINEAR SYSTEM C QRX = PAX = B WHERE Q, R, AND P ARE DETERMINED FROM A BY DORTHO C CONTROL C C DIMENSION QR(MS,N), S(N), IP(N), X(M) C . C . C . C CALL DORSOL(M, N, QR, MS, S, IP, X) C C WHERE C M IS AN INTEGER INPUT VARIABLE, THE NUMBER OF ROWS OF A. C N IS AN INTEGER INPUT VARIABLE, THE NUMBER OF COLUMNS OF A C (1 .LT. N .LE. M). C QR IS A REAL INPUT ARRAY, THE ORTHOGONAL AND TRIANGULAR FACTORS C OF A PRODUCED BY DORTHO. C MS IS AN INTEGER INPUT VARIABLE, THE LEADING DIMENSION OF C QR IN THE CALLING PROGRAM. C S IS A REAL INPUT ARRAY, THE RELEVANT PARTS OF Q PRODUCED BY C DORTHO. C IP IS AN INTEGER INPUT ARRAY, THE PERMUTATION INFORMATION C PRODUCED BY DORTHO. C X AS A REAL INPUT ARRAY IS THE RIGHT-HAND SIDE B OF AX = B. C X AS A REAL OUTPUT ARRAY IS X(I), I = 1, ..., N, THE LEAST C SQUARES SOLUTION, AND X(J), J = N+1, ..., M, THE VECTOR C WHOSE LENGTH IS THE MINIMUM OF ALL RESIDUAL B - AX. C METHOD C THE FACTORED SYSTEM QRX = PAX = PB ARE SOLVED IN THE SEQUENCE C OF QY = PB AND RX = Y. FULL RANK FOR THE MATRIX A IS ASSUMED C WHICH CAN BE CHECKED BY INTERROGATING THE LOGICAL OUTPUT C VARIABLE PRODUCED BY DORTHO. C REFERENCES C (1) PETER BUSINGER AND G.H. GOLUB, LINEAR LEAST SQUARES SOLU- C TIONS BY HOUSEHOLDER TRANSFORMATIONS, NUMER. MATH. 7(1965), C 269-276. C (2) N.K. TSAO AND P.J. NIKOLAI, PROCEDURES USING ORTHOGONAL C TRANSFORMATIONS FOR LINEAR LEAST SQUARES PROBLEMS, ARL C TECHNICAL REPORT ARL TR 74-0124(1974). C*********************************************************************** DOUBLE PRECISION QR(MS,N), S(N), X(M) INTEGER IP(N) DOUBLE PRECISION SAV, SS, Y C NN = N IF(N .EQ. M) NN = N - 1 DO 30 J = 1, NN JP = J + 1 IJ = IP(J) Y = 1.D0 - S(J) SAV = X(J) X(J) = X(IJ) X(IJ) = SAV C PREMULTIPLY X WITH THE J-TH C ORTHOGONAL MATRIX. SAV = X(J) DO 10 K = JP, M 10 SAV = SAV + QR(K,J)*X(K) SS = X(J) X(J) = SAV/S(J) SS = (SS - X(J))/Y DO 20 K = JP, M 20 X(K) = X(K) - QR(K,J)*SS 30 CONTINUE C BACK SUBSTITUTE TO FIND THE C LEAST SQUARES SOLUTION. X(N) = X(N)/QR(N,N) NM = N - 1 DO 50 I = 1, NM NI = N - I NN = N DO 40 J = 1, I X(NI) = X(NI) - QR(NI,NN)*X(NN) 40 NN = NN - 1 X(NI) = X(NI)/QR(NI,NI) 50 CONTINUE RETURN END SUBROUTINE LSQR (IND, A, MDA, M, N, B, MDB, NB, RE, AE, KRANK, * KSURE, RNORM, WORK, LW, IWORK, LIW, IERR) C----------------------------------------------------------------------- C C LEAST SQUARES SOLUTION OF LINEAR EQUATIONS C C -------------- C C LSQR SOLVES BOTH UNDERDETERMINED AND OVERDETERMINED LINEAR C SYSTEMS AX = B, WHERE A IS AN M BY N MATRIX AND B IS AN M BY C NB MATRIX OF RIGHT HAND SIDES. IF M .GE. N, THE LEAST SQUARES C SOLUTION IS COMPUTED BY DECOMPOSING THE MATRIX A INTO THE C PRODUCT OF AN ORTHOGONAL MATRIX Q AND UPPER TRIANGULAR MATRIX C R (QR FACTORIZATION). IF M .LT. N, THE MINIMAL LENGTH SOLUTION C IS COMPUTED BY FACTORING THE MATRIX A INTO THE PRODUCT OF A C LOWER TRIANGULAR MATRIX L AND ORTHOGONAL MATRIX Q (LQ FACTOR- C IZATION). IF THE MATRIX A IS DETERMINED TO BE RANK DEFICIENT, C THEN THE MINIMAL LENGTH LEAST SQUARES SOLUTION IS COMPUTED. C C USER INPUT BOUNDS ON THE UNCERTAINTY OF THE ELEMENTS OF A ARE C USED TO DETECT NUMERICAL RANK DEFICIENCY. THE ALGORITHM USES C A ROW AND COLUMN PIVOT STRATEGY TO MINIMIZE THE GROWTH OF C UNCERTAINTY AND ROUND-OFF ERRORS. C C ****************************************************************** C * * C * WARNING - ALL INPUT ARRAYS ARE CHANGED ON EXIT. * C * * C ****************************************************************** C C INPUT.. C C IND INTEGER WHICH INDICATES IF THE ROUTINE IS BEING C CALLED FOR THE FIRST TIME. C IND = 0 ORIGINAL CALL C IND .NE. 0 SUBSEQUENT CALLS C ON SUBSEQUENT CALLS A NEW SET B OF EQUATIONS CAN C BE SOLVED (USING THE SAME COEFFICIENT MATRIX A). C IT IS ASSUMED THAT A, MDA, M, N, KRANK, IWORK, C LIW, AND THE FIRST 2*MIN(M,N) LOCATIONS OF WORK C HAVE NOT BEEN MODIFIED BY THE USER. RE, AE, AND C KSURE ARE NOT USED. C C A(,) LINEAR COEFFICIENT MATRIX OF AX=B, WITH MDA THE C MDA,M,N ACTUAL FIRST DIMENSION OF A IN THE CALLING PROGRAM. C M IS THE ROW DIMENSION (NO. OF EQUATIONS OF THE C PROBLEM) AND N THE COL DIMENSION (NO. OF UNKNOWNS). C MUST HAVE MDA .GE. M. C C B(,) RIGHT HAND SIDE(S), WITH MDB THE ACTUAL FIRST C MDB,NB DIMENSION OF B IN THE CALLING PROGRAM. NB IS THE C NUMBER OF M BY 1 RIGHT HAND SIDES. MUST HAVE C MDB .GE. MAX(M,N). IF NB .LE. 0 THEN B AND MDB C ARE IGNORED. C C RE RE IS THE MAXIMUM RELATIVE UNCERTAINTY OF THE C ELEMENTS OF THE MATRIX A (0 .LE. RE .LT. 1). C C AE AE IS THE MAXIMUM ABSOLUTE UNCERTAINTY OF THE C ELEMENTS OF THE MATRIX A (AE .GE. 0). C C WORK() A REAL WORK ARRAY DIMENSIONED 5*MIN(M,N). C C LW ACTUAL DIMENSION OF WORK C C IWORK() INTEGER WORK ARRAY DIMENSIONED AT LEAST N+M. C C LIW ACTUAL DIMENSION OF IWORK. C C OUTPUT.. C C A(,) CONTAINS THE TRIANGULAR PART OF THE REDUCED MATRIX C AND THE TRANSFORMATION INFORMATION. A AND THE FIRST C 2*MIN(M,N) ELEMENTS OF WORK (SEE BELOW) COMPLETELY C SPECIFY THE FACTORIZATION OF THE MATRIX A. C C B(,) CONTAINS THE N BY NB SOLUTION MATRIX FOR X. C C KRANK,KSURE THE NUMERICAL RANK OF A, BASED UPON THE RELATIVE C AND ABSOLUTE BOUNDS ON UNCERTAINTY, IS BOUNDED C ABOVE BY KRANK AND BELOW BY KSURE. THE ALGORITHM C RETURNS A SOLUTION BASED ON KRANK. KSURE PROVIDES C AN INDICATION OF THE PRECISION OF THE RANK. C C RNORM() CONTAINS THE EUCLIDEAN LENGTH OF THE NB RESIDUAL C VECTORS B(I) - AX(I), I=1,...,NB. C C WORK() THE FIRST 2*MIN(M,N) LOCATIONS OF WORK CONTAIN C THE VALUES NECESSARY TO REPRODUCE THE HOUSEHOLDER C FACTORIZATION OF A. C C IWORK() AN ARRAY OF LENGTH M + N CONTAINING THE ORDERS IN C WHICH THE ROWS AND COLUMNS WERE USED. IF M .GE. N C THEN THE FIRST N LOCATIONS CONTAIN THE ORDER OF C THE COLUMNS AND THE NEXT M LOCATIONS THE ORDER OF C THE ROWS. IF M .LT. N THEN THE ORDER OF THE ROWS C PRECEDES THE ORDER OF THE COLUMNS. C C IERR FLAG TO INDICATE THE STATUS OF THE RESULTS C 0 - SATISFACTORY COMPLETION C .GT. 0 - INPUT ERROR C C---------------- C THE SUBROUTINES U11LS, U12LS, U11US, AND U12US WERE WRITTEN BY C T. MANTEUFFEL (LANL) IN 1981. THE DRIVER ROUTINE LSQR WAS WRITTEN C BY A.H. MORRIS (NSWC) IN 1991. C---------------- C REFERENCE. MANTEUFFEL, T., AN INTERVAL ANALYSIS APPROACH TO RANK C DETERMINATION IN LINEAR LEAST SQUARES PROBLEMS, C SANDIA LABORATORIES REPORT SAND80-0655, JUNE, 1980. C----------------------------------------------------------------------- REAL A(MDA,N), B(MDB,*), RNORM(*), WORK(LW) INTEGER IWORK(LIW) C---------------- C NP IF M .GE. N THEN THE FIRST NP COLUMNS OF A C ARE NEVER INTERCHANGED. C IF M .LT. N THEN THE FIRST NP ROWS OF A ARE C NEVER INTERCHANGED. NP IS NOT REFERENCED ON C A CONTINUATION CALL TO THE ROUTINE. C C MODE THE INTEGER MODE INDICATES HOW THE ROUTINE C IS TO REACT IF RANK DEFICIENCY IS DETECTED. C IF MODE = 0 RETURN IMMEDIATELY, NO SOLUTION C 1 COMPUTE TRUNCATED SOLUTION C 2 COMPUTE MINIMAL LENGTH SOLUTION C MODE MUST NOT BE MODIFIED ON A CONTINUATION C CALL TO THE ROUTINE. IF MODE LT. 2, ONLY THE C FIRST N LOCATIONS OF WORK ARE USED. C---------------- NP = 0 MODE = 2 C C CHECK THE INPUT C IF (NB .LE. 0 .AND. IND .NE. 0) GO TO 200 IF (M .LT. 1 .OR. N .LT. 1) GO TO 210 IF (MDA .LT. M) GO TO 220 IF (LIW .LT. M + N) GO TO 240 C M0 = MIN0(M,N) N0 = MAX0(M,N) C NUM = 0 C IF (NB .LE. 0) GO TO 10 IF (MDB .LT. N0) GO TO 230 IF (IND .NE. 0) GO TO 100 C 10 IF (LW .LT. 5*M0) GO TO 250 IF (RE .LT. 0.0 .OR. AE .LT. 0.0) GO TO 260 C C DEFINE THE RELATIVE AND ABSOLUTE TOLERANCE LISTS C M1 = 1 M2 = M1 + M0 M3 = M2 + M0 M4 = M3 + M0 M5 = M4 + M0 C EPS = 10.0*SPMPAR(1) RERR = AMAX1(EPS,RE) C IMAX = M5 - 1 DO 20 I = M4,IMAX WORK(I) = RERR 20 CONTINUE IMAX = IMAX + M0 DO 30 I = M5,IMAX WORK(I) = AE 30 CONTINUE C C FACTOR THE MATRIX A C C NUM = NP IF (M .LT. N) GO TO 40 C CALL U11LS (A,MDA,M,N,WORK(M4),WORK(M5),MODE,NP,KRANK,KSURE, * WORK(M1),WORK(M2),WORK(M3),IWORK(M1),IWORK(M2)) GO TO 100 C 40 CALL U11US (A,MDA,M,N,WORK(M4),WORK(M5),MODE,NP,KRANK,KSURE, * WORK(M1),WORK(M2),WORK(M3),IWORK(M1),IWORK(M2)) C C SOLUTION PHASE C 100 IERR = 0 INFO = 0 IF (KRANK .EQ. M0) GO TO 110 IF (KRANK .EQ. 0) GO TO 110 C IF (KRANK .LT. NUM) GO TO 280 C IF (MODE .EQ. 0) RETURN INFO = MODE C 110 IF (NB .LE. 0) RETURN C M1 = 1 M2 = 1 + M0 IF (INFO .EQ. 2) GO TO 130 C C ONLY MIN(M,N) ELEMENTS OF WORK ARE NEEDED C IF (LW .LT. M0) GO TO 250 IF (M .LT. N) GO TO 120 C CALL U12LS (A,MDA,M,N,B,MDB,NB,MODE,KRANK,RNORM, * WORK(M1),WORK(M1),IWORK(M1),IWORK(M2)) RETURN C 120 CALL U12US (A,MDA,M,N,B,MDB,NB,MODE,KRANK,RNORM, * WORK(M1),WORK(M1),IWORK(M1),IWORK(M2)) RETURN C C HERE 2*MIN(M,N) ELEMENTS OF WORK ARE NEEDED C 130 IF (LW .LT. 2*M0) GO TO 250 IF (M .LT. N) GO TO 140 C CALL U12LS (A,MDA,M,N,B,MDB,NB,MODE,KRANK,RNORM, * WORK(M1),WORK(M2),IWORK(M1),IWORK(M2)) RETURN C 140 CALL U12US (A,MDA,M,N,B,MDB,NB,MODE,KRANK,RNORM, * WORK(M1),WORK(M2),IWORK(M1),IWORK(M2)) RETURN C C ERROR RETURN C C NB .LE. 0 ON A CONTINUATION CALL 200 IERR = 7 RETURN C M .LT. 1 OR N .LT. 1 210 IERR = 1 RETURN C MDA .LT. M 220 IERR = 2 RETURN C MDB .LT. MAX(M,N) 230 IERR = 3 RETURN C LIW .LT. M + N 240 IERR = 4 RETURN C LW TOO SMALL 250 IERR = 5 RETURN C RE OR AE IS NEGATIVE 260 IERR = 6 RETURN C 0 .LT. KRANK .LT. NP C 280 IERR = 8 C RETURN END SUBROUTINE U11LS (A,MDA,M,N,UB,DB,MODE,NP,KRANK,KSURE,H,W,EB, * IC,IR) C C THIS ROUTINE PERFORMS A QR FACTORIZATION OF A C USING HOUSEHOLDER TRANSFORMATIONS. ROW AND C COLUMN PIVOTS ARE CHOSEN TO REDUCE THE GROWTH C OF ROUND-OFF AND TO HELP DETECT POSSIBLE RANK C DEFICIENCY. C DIMENSION A(MDA,N),UB(N),DB(N),H(N),W(N),EB(N) INTEGER IC(N),IR(M) C C INITIALIZATION C J = 0 KRANK = N DO 10 I = 1,N IC(I) = I 10 CONTINUE DO 20 I = 1,M IR(I) = I 20 CONTINUE C C DETERMINE REL AND ABS ERROR VECTORS C C C CALCULATE COL LENGTH C DO 30 I = 1,N H(I) = SNRM2(M,A(1,I),1) W(I) = H(I) 30 CONTINUE C C INITIALIZE ERROR BOUNDS C DO 40 I = 1,N EB(I) = AMAX1(DB(I),UB(I)*H(I)) UB(I) = EB(I) DB(I) = 0.0 40 CONTINUE C C DISCARD SELF DEPENDENT COLUMNS C I = 1 50 IF (EB(I) .GE. H(I)) GO TO 60 IF (I .EQ. KRANK) GO TO 70 I = I + 1 GO TO 50 C C MATRIX REDUCTION C 60 KK = KRANK KRANK = KRANK - 1 IF (MODE .EQ. 0) RETURN IF (I .LE. NP) GO TO 400 IF (I .GT. KRANK) GO TO 70 CALL SSWAP (1,EB(I),1,EB(KK),1) CALL SSWAP (1,UB(I),1,UB(KK),1) CALL SSWAP (1,W(I),1,W(KK),1) CALL SSWAP (1,H(I),1,H(KK),1) CALL ISWAP (1,IC(I),1,IC(KK),1) CALL SSWAP (M,A(1,I),1,A(1,KK),1) GO TO 50 C C TEST FOR ZERO RANK C 70 IF (KRANK .GT. 0) GO TO 100 KRANK = 0 KSURE = 0 RETURN C C M A I N L O O P C 100 J = J + 1 JP1 = J + 1 JM1 = J - 1 KZ = KRANK IF (J .LE. NP) KZ = J C C EACH COL HAS MM=M-J+1 COMPONENTS C MM = M - J + 1 C C UB DETERMINES COLUMN PIVOT C 110 IMIN = J IF (H(J) .EQ. 0.0) GO TO 170 RMIN = UB(J)/H(J) DO 120 I = J,KZ IF (UB(I) .GE. H(I)*RMIN) GO TO 120 RMIN = UB(I)/H(I) IMIN = I 120 CONTINUE C C TEST FOR RANK DEFICIENCY C IF (RMIN .LT. 1.0) GO TO 200 TT = (EB(IMIN) + ABS(DB(IMIN)))/H(IMIN) IF (TT .GE. 1.0) GO TO 170 C C COMPUTE EXACT UB C DO 125 I = 1,JM1 W(I) = A(I,IMIN) 125 CONTINUE C L = JM1 130 W(L) = W(L)/A(L,L) IF (L .EQ. 1) GO TO 150 LM1 = L - 1 DO 140 I = L,JM1 W(LM1) = W(LM1) - A(LM1,I)*W(I) 140 CONTINUE L = LM1 GO TO 130 C 150 TT = EB(IMIN) DO 160 I = 1,JM1 TT = TT + ABS(W(I))*EB(I) 160 CONTINUE UB(IMIN) = TT IF (UB(IMIN)/H(IMIN) .GE. 1.0) GO TO 170 GO TO 200 C C MATRIX REDUCTION C 170 KK = KRANK KRANK = KRANK - 1 KZ = KRANK IF (MODE .EQ. 0) RETURN IF (J .LE. NP) GO TO 410 IF (IMIN .GT. KRANK) GO TO 180 CALL ISWAP (1,IC(IMIN),1,IC(KK),1) CALL SSWAP (M,A(1,IMIN),1,A(1,KK),1) CALL SSWAP (1,EB(IMIN),1,EB(KK),1) CALL SSWAP (1,UB(IMIN),1,UB(KK),1) CALL SSWAP (1,DB(IMIN),1,DB(KK),1) CALL SSWAP (1,W(IMIN),1,W(KK),1) CALL SSWAP (1,H(IMIN),1,H(KK),1) 180 IF (J .GT. KRANK) GO TO 300 GO TO 110 C C COLUMN PIVOT C 200 IF (IMIN .EQ. J) GO TO 210 CALL SSWAP (1,H(J),1,H(IMIN),1) CALL SSWAP (M,A(1,J),1,A(1,IMIN),1) CALL SSWAP (1,EB(J),1,EB(IMIN),1) CALL SSWAP (1,UB(J),1,UB(IMIN),1) CALL SSWAP (1,DB(J),1,DB(IMIN),1) CALL SSWAP (1,W(J),1,W(IMIN),1) CALL ISWAP (1,IC(J),1,IC(IMIN),1) C C ROW PIVOT C 210 JMAX = ISAMAX(MM,A(J,J),1) JMAX = JMAX + J - 1 IF (JMAX .EQ. J) GO TO 220 CALL SSWAP (N,A(J,1),MDA,A(JMAX,1),MDA) CALL ISWAP (1,IR(J),1,IR(JMAX),1) C C APPLY HOUSEHOLDER TRANSFORMATION C 220 TN = SNRM2(MM,A(J,J),1) IF (TN .EQ. 0.0) GO TO 170 IF (A(J,J) .NE. 0.0) TN = SIGN(TN,A(J,J)) CALL SSCAL (MM,1.0/TN,A(J,J),1) A(J,J) = A(J,J) + 1.0 IF (J .EQ. N) GO TO 250 DO 240 I = JP1,N BB = -SDOT(MM,A(J,J),1,A(J,I),1)/A(J,J) CALL SAXPY (MM,BB,A(J,J),1,A(J,I),1) IF (I .LE. NP) GO TO 240 IF (H(I) .EQ. 0.0) GO TO 240 TT = 1.0 - (A(J,I)/H(I))**2 TT = AMAX1(TT,0.0) T = TT TT = 1.0 + 0.05*TT*(H(I)/W(I))**2 IF (TT .EQ. 1.0) GO TO 230 H(I) = H(I)*SQRT(T) GO TO 240 230 H(I) = SNRM2(M-J,A(J+1,I),1) W(I) = H(I) 240 CONTINUE C 250 H(J) = A(J,J) A(J,J) = -TN C C UPDATE UB, DB C UB(J) = UB(J)/ABS(A(J,J)) DB(J) = (SIGN(EB(J),DB(J)) + DB(J))/A(J,J) IF (J .EQ. KRANK) GO TO 300 DO 260 I = JP1,KRANK UB(I) = UB(I) + ABS(A(J,I))*UB(J) DB(I) = DB(I) - A(J,I)*DB(J) 260 CONTINUE GO TO 100 C C E N D M A I N L O O P C 300 CONTINUE C C COMPUTE KSURE C KM1 = KRANK - 1 DO 315 I = 1,KM1 IS = 0 KMI = KRANK - I DO 310 II = 1,KMI IF (UB(II) .LE. UB(II + 1)) GO TO 310 IS = 1 TEMP = UB(II) UB(II) = UB(II + 1) UB(II + 1) = TEMP 310 CONTINUE IF (IS .EQ. 0) GO TO 320 315 CONTINUE C 320 KSURE = 0 SUM = 0.0 DO 325 I = 1,KRANK R2 = UB(I)*UB(I) IF (R2 + SUM .GE. 1.0) GO TO 330 SUM = SUM + R2 KSURE = KSURE + 1 325 CONTINUE C C IF SYSTEM IS OF REDUCED RANK AND MODE = 2 C COMPLETE THE DECOMPOSITION FOR SHORTEST LEAST SQUARES SOLUTION C 330 IF (KRANK .EQ. N .OR. MODE .LT. 2) RETURN NMK = N - KRANK KP1 = KRANK + 1 I = KRANK 340 TN = SNRM2(NMK,A(I,KP1),MDA)/A(I,I) TN = A(I,I)*SQRT(1.0 + TN*TN) CALL SSCAL (NMK,1.0/TN,A(I,KP1),MDA) W(I) = A(I,I)/TN + 1.0 A(I,I) = -TN IF (I .EQ. 1) GO TO 350 IM1 = I - 1 DO 345 II = 1,IM1 TT = -SDOT(NMK,A(II,KP1),MDA,A(I,KP1),MDA)/W(I) TT = TT - A(II,I) CALL SAXPY (NMK,TT,A(I,KP1),MDA,A(II,KP1),MDA) A(II,I) = A(II,I) + TT*W(I) 345 CONTINUE I = I - 1 GO TO 340 C 350 CONTINUE RETURN C C FIRST NP COLUMNS ARE LINEARLY DEPENDENT C 400 KRANK = I - 1 RETURN 410 KRANK = J - 1 RETURN END SUBROUTINE U12LS (A,MDA,M,N,B,MDB,NB,MODE,KRANK,RNORM,H,W,IC,IR) C C GIVEN THE HOUSEHOLDER QR FACTORIZATION OF A, THIS C SUBROUTINE SOLVES THE SYSTEM AX=B. IF THE SYSTEM C IS OF REDUCED RANK, THIS ROUTINE RETURNS A SOLUTION C ACCORDING TO THE SELECTED MODE. C C NOTE - IF MODE.NE.2, W IS NEVER ACCESSED. C DIMENSION A(MDA,N),B(MDB,NB),RNORM(NB),H(N),W(N) INTEGER IC(N),IR(M) C K = KRANK KP1 = K + 1 IF (K .GT. 0) GO TO 30 C C RANK=0 C DO 10 JB = 1,NB RNORM(JB) = SNRM2(M,B(1,JB),1) 10 CONTINUE DO 21 JB = 1,NB DO 20 I = 1,N B(I,JB) = 0.0 20 CONTINUE 21 CONTINUE RETURN C 30 I = 0 C C REORDER B TO REFLECT ROW INTERCHANGES C 40 I = I + 1 IF (I .EQ. M) GO TO 100 J = IR(I) IF (J .EQ. I) GO TO 40 IF (J .LT. 0) GO TO 40 C IR(I) = -IR(I) DO 50 JB = 1,NB RNORM(JB) = B(I,JB) 50 CONTINUE C IJ = I 60 DO 70 JB = 1,NB B(IJ,JB) = B(J,JB) 70 CONTINUE IJ = J J = IR(IJ) IR(IJ) = -IR(IJ) IF (J .NE. I) GO TO 60 C DO 80 JB = 1,NB B(IJ,JB) = RNORM(JB) 80 CONTINUE GO TO 40 C 100 DO 110 I = 1,M IR(I) = IABS(IR(I)) 110 CONTINUE C C APPLY HOUSEHOLDER TRANSFORMATIONS TO B C DO 130 J = 1,K TT = A(J,J) A(J,J) = H(J) DO 120 I = 1,NB BB = -SDOT (M-J+1,A(J,J),1,B(J,I),1)/H(J) CALL SAXPY (M-J+1,BB,A(J,J),1,B(J,I),1) 120 CONTINUE A(J,J) = TT 130 CONTINUE C C FIND NORMS OF RESIDUAL VECTOR(S)..(BEFORE OVERWRITE B) C DO 140 JB = 1,NB RNORM(JB) = SNRM2(M-K,B(KP1,JB),1) 140 CONTINUE C C BACK SOLVE UPPER TRIANGULAR R C I = K 150 DO 160 JB = 1,NB B(I,JB) = B(I,JB)/A(I,I) 160 CONTINUE IF (I .EQ. 1) GO TO 200 IM1 = I - 1 DO 170 JB = 1,NB CALL SAXPY (IM1,-B(I,JB),A(1,I),1,B(1,JB),1) 170 CONTINUE I = IM1 GO TO 150 C C RANK LT N C C TRUNCATED SOLUTION C 200 IF (K .EQ. N) GO TO 230 DO 211 JB = 1,NB DO 210 I = KP1,N B(I,JB) = 0.0 210 CONTINUE 211 CONTINUE IF (MODE .EQ. 1) GO TO 230 C C MINIMAL LENGTH SOLUTION C NMK = N - K DO 221 JB = 1,NB DO 220 I = 1,K TT = -SDOT(NMK,A(I,KP1),MDA,B(KP1,JB),1)/W(I) TT = TT - B(I,JB) CALL SAXPY (NMK,TT,A(I,KP1),MDA,B(KP1,JB),1) B(I,JB) = B(I,JB) + TT*W(I) 220 CONTINUE 221 CONTINUE C C REORDER B TO REFLECT COLUMN INTERCHANGES C 230 I = 0 C 240 I = I + 1 IF (I .EQ. N) GO TO 260 J = IC(I) IF (J .EQ. I) GO TO 240 IF (J .LT. 0) GO TO 240 C IC(I) = -IC(I) 250 CALL SSWAP (NB,B(J,1),MDB,B(I,1),MDB) IJ = IC(J) IC(J) = -IC(J) J = IJ IF (J .NE. I) GO TO 250 GO TO 240 C 260 DO 270 I = 1,N IC(I) = IABS(IC(I)) 270 CONTINUE RETURN END SUBROUTINE U11US (A,MDA,M,N,UB,DB,MODE,NP,KRANK,KSURE,H,W,EB, * IR,IC) C C THIS ROUTINE PERFORMS AN LQ FACTORIZATION OF THE C MATRIX A USING HOUSEHOLDER TRANSFORMATIONS. ROW C AND COLUMN PIVOTS ARE CHOSEN TO REDUCE THE GROWTH C OF ROUND-OFF AND TO HELP DETECT POSSIBLE RANK C DEFICIENCY. C DIMENSION A(MDA,N),UB(M),DB(M),H(M),W(M),EB(M) INTEGER IC(N),IR(M) C C INITIALIZATION C J = 0 KRANK = M DO 10 I = 1,N IC(I) = I 10 CONTINUE DO 20 I = 1,M IR(I) = I 20 CONTINUE C C DETERMINE REL AND ABS ERROR VECTORS C C C CALCULATE ROW LENGTH C DO 30 I = 1,M H(I) = SNRM2(N,A(I,1),MDA) W(I) = H(I) 30 CONTINUE C C INITIALIZE ERROR BOUNDS C DO 40 I = 1,M EB(I) = AMAX1(DB(I),UB(I)*H(I)) UB(I) = EB(I) DB(I) = 0.0 40 CONTINUE C C DISCARD SELF DEPENDENT ROWS C I = 1 50 IF (EB(I) .GE. H(I)) GO TO 60 IF (I .EQ. KRANK) GO TO 70 I = I + 1 GO TO 50 C C MATRIX REDUCTION C 60 KK = KRANK KRANK = KRANK - 1 IF (MODE .EQ. 0) RETURN IF (I .LE. NP) GO TO 400 IF (I .GT. KRANK) GO TO 70 CALL SSWAP (1,EB(I),1,EB(KK),1) CALL SSWAP (1,UB(I),1,UB(KK),1) CALL SSWAP (1,W(I),1,W(KK),1) CALL SSWAP (1,H(I),1,H(KK),1) CALL ISWAP (1,IR(I),1,IR(KK),1) CALL SSWAP (N,A(I,1),MDA,A(KK,1),MDA) GO TO 50 C C TEST FOR ZERO RANK C 70 IF (KRANK .GT. 0) GO TO 100 KRANK = 0 KSURE = 0 RETURN C C M A I N L O O P C 100 J = J + 1 JP1 = J + 1 JM1 = J - 1 KZ = KRANK IF (J .LE. NP) KZ = J C C EACH ROW HAS NN=N-J+1 COMPONENTS C NN = N - J + 1 C C UB DETERMINES ROW PIVOT C 110 IMIN = J IF (H(J) .EQ. 0.0) GO TO 170 RMIN = UB(J)/H(J) DO 120 I = J,KZ IF (UB(I) .GE. H(I)*RMIN) GO TO 120 RMIN = UB(I)/H(I) IMIN = I 120 CONTINUE C C TEST FOR RANK DEFICIENCY C IF (RMIN .LT. 1.0) GO TO 200 TT = (EB(IMIN) + ABS(DB(IMIN)))/H(IMIN) IF (TT .GE. 1.0) GO TO 170 C C COMPUTE EXACT UB C DO 125 I = 1,JM1 W(I) = A(IMIN,I) 125 CONTINUE C L = JM1 130 W(L) = W(L)/A(L,L) IF (L .EQ. 1) GO TO 150 LM1 = L - 1 DO 140 I = L,JM1 W(LM1) = W(LM1) - A(I,LM1)*W(I) 140 CONTINUE L = LM1 GO TO 130 C 150 TT = EB(IMIN) DO 160 I = 1,JM1 TT = TT + ABS(W(I))*EB(I) 160 CONTINUE UB(IMIN) = TT IF (UB(IMIN)/H(IMIN) .GE. 1.0) GO TO 170 GO TO 200 C C MATRIX REDUCTION C 170 KK = KRANK KRANK = KRANK - 1 KZ = KRANK IF (MODE .EQ. 0) RETURN IF (J .LE. NP) GO TO 410 IF (IMIN .GT. KRANK) GO TO 180 CALL ISWAP (1,IR(IMIN),1,IR(KK),1) CALL SSWAP (N,A(IMIN,1),MDA,A(KK,1),MDA) CALL SSWAP (1,EB(IMIN),1,EB(KK),1) CALL SSWAP (1,UB(IMIN),1,UB(KK),1) CALL SSWAP (1,DB(IMIN),1,DB(KK),1) CALL SSWAP (1,W(IMIN),1,W(KK),1) CALL SSWAP (1,H(IMIN),1,H(KK),1) 180 IF (J .GT. KRANK) GO TO 300 GO TO 110 C C ROW PIVOT C 200 IF (IMIN .EQ. J) GO TO 210 CALL SSWAP (1,H(J),1,H(IMIN),1) CALL SSWAP (N,A(J,1),MDA,A(IMIN,1),MDA) CALL SSWAP (1,EB(J),1,EB(IMIN),1) CALL SSWAP (1,UB(J),1,UB(IMIN),1) CALL SSWAP (1,DB(J),1,DB(IMIN),1) CALL SSWAP (1,W(J),1,W(IMIN),1) CALL ISWAP (1,IR(J),1,IR(IMIN),1) C C COLUMN PIVOT C 210 JMAX = ISAMAX(NN,A(J,J),MDA) JMAX = JMAX + J - 1 IF (JMAX .EQ. J) GO TO 220 CALL SSWAP (M,A(1,J),1,A(1,JMAX),1) CALL ISWAP (1,IC(J),1,IC(JMAX),1) C C APPLY HOUSEHOLDER TRANSFORMATION C 220 TN = SNRM2(NN,A(J,J),MDA) IF (TN .EQ. 0.0) GO TO 170 IF (A(J,J) .NE. 0.0) TN = SIGN(TN,A(J,J)) CALL SSCAL (NN,1.0/TN,A(J,J),MDA) A(J,J) = A(J,J) + 1.0 IF (J .EQ. M) GO TO 250 DO 240 I = JP1,M BB = -SDOT(NN,A(J,J),MDA,A(I,J),MDA)/A(J,J) CALL SAXPY (NN,BB,A(J,J),MDA,A(I,J),MDA) IF (I .LE. NP) GO TO 240 IF (H(I) .EQ. 0.0) GO TO 240 TT = 1.0 - (A(I,J)/H(I))**2 TT = AMAX1(TT,0.0) T = TT TT = 1.0 + 0.05*TT*(H(I)/W(I))**2 IF (TT .EQ. 1.0) GO TO 230 H(I) = H(I)*SQRT(T) GO TO 240 230 H(I) = SNRM2(N-J,A(I,J+1),MDA) W(I) = H(I) 240 CONTINUE C 250 H(J) = A(J,J) A(J,J) = -TN C C UPDATE UB, DB C UB(J) = UB(J)/ABS(A(J,J)) DB(J) = (SIGN(EB(J),DB(J))+DB(J))/A(J,J) IF (J .EQ. KRANK) GO TO 300 DO 260 I = JP1,KRANK UB(I) = UB(I) + ABS(A(I,J))*UB(J) DB(I) = DB(I) - A(I,J)*DB(J) 260 CONTINUE GO TO 100 C C E N D M A I N L O O P C 300 CONTINUE C C COMPUTE KSURE C KM1 = KRANK - 1 DO 315 I = 1,KM1 IS = 0 KMI = KRANK - I DO 310 II = 1,KMI IF (UB(II) .LE. UB(II + 1)) GO TO 310 IS = 1 TEMP = UB(II) UB(II) = UB(II + 1) UB(II + 1) = TEMP 310 CONTINUE IF (IS .EQ. 0) GO TO 320 315 CONTINUE C 320 KSURE = 0 SUM = 0.0 DO 325 I = 1,KRANK R2 = UB(I)*UB(I) IF (R2 + SUM .GE. 1.0) GO TO 330 SUM = SUM + R2 KSURE = KSURE + 1 325 CONTINUE C C IF SYSTEM IS OF REDUCED RANK AND MODE = 2 C COMPLETE THE DECOMPOSITION FOR SHORTEST LEAST SQUARES SOLUTION C 330 IF (KRANK .EQ. M .OR. MODE .LT. 2) RETURN MMK = M - KRANK KP1 = KRANK + 1 I = KRANK 340 TN = SNRM2(MMK,A(KP1,I),1)/A(I,I) TN = A(I,I)*SQRT(1.0 + TN*TN) CALL SSCAL (MMK,1.0/TN,A(KP1,I),1) W(I) = A(I,I)/TN + 1.0 A(I,I) = -TN IF (I .EQ. 1) GO TO 350 IM1 = I - 1 DO 345 II = 1,IM1 TT = -SDOT(MMK,A(KP1,II),1,A(KP1,I),1)/W(I) TT = TT - A(I,II) CALL SAXPY (MMK,TT,A(KP1,I),1,A(KP1,II),1) A(I,II) = A(I,II) + TT*W(I) 345 CONTINUE I = I - 1 GO TO 340 C 350 CONTINUE RETURN C C FIRST NP ROWS ARE LINEARLY DEPENDENT C 400 KRANK = I - 1 RETURN 410 KRANK = J - 1 RETURN END SUBROUTINE U12US (A,MDA,M,N,B,MDB,NB,MODE,KRANK,RNORM,H,W,IR,IC) C C GIVEN THE HOUSEHOLDER LQ FACTORIZATION OF A, THIS C SUBROUTINE SOLVES THE SYSTEM AX=B. IF THE SYSTEM C IS OF REDUCED RANK, THIS ROUTINE RETURNS A SOLUTION C ACCORDING TO THE SELECTED MODE. C C NOTE - IF MODE.NE.2, W IS NEVER ACCESSED. C DIMENSION A(MDA,N),B(MDB,NB),RNORM(NB),H(M),W(M) INTEGER IC(N),IR(M) C K = KRANK KP1 = K + 1 IF (K .GT. 0) GO TO 30 C C RANK=0 C DO 10 JB = 1,NB RNORM(JB) = SNRM2(M,B(1,JB),1) 10 CONTINUE DO 21 JB = 1,NB DO 20 I = 1,N B(I,JB) = 0.0 20 CONTINUE 21 CONTINUE RETURN C 30 I = 0 C C REORDER B TO REFLECT ROW INTERCHANGES C 40 I = I + 1 IF (I .EQ. M) GO TO 100 J = IR(I) IF (J .EQ. I) GO TO 40 IF (J .LT. 0) GO TO 40 C IR(I) = -IR(I) DO 50 JB = 1,NB RNORM(JB) = B(I,JB) 50 CONTINUE C IJ = I 60 DO 70 JB = 1,NB B(IJ,JB) = B(J,JB) 70 CONTINUE IJ = J J = IR(IJ) IR(IJ) = -IR(IJ) IF (J .NE. I) GO TO 60 C DO 80 JB = 1,NB B(IJ,JB) = RNORM(JB) 80 CONTINUE GO TO 40 C 100 DO 110 I = 1,M IR(I) = IABS(IR(I)) 110 CONTINUE C C IF A IS OF REDUCED RANK AND MODE=2, C APPLY HOUSEHOLDER TRANSFORMATIONS TO B C IF (MODE .LT. 2 .OR. K .EQ. M) GO TO 140 MMK = M - K DO 130 JB = 1,NB DO 120 J = 1,K I = KP1 - J TT = -SDOT(MMK,A(KP1,I),1,B(KP1,JB),1)/W(I) TT = TT - B(I,JB) CALL SAXPY (MMK,TT,A(KP1,I),1,B(KP1,JB),1) B(I,JB) = B(I,JB) + TT*W(I) 120 CONTINUE 130 CONTINUE C C FIND NORMS OF RESIDUAL VECTOR(S)..(BEFORE OVERWRITE B) C 140 DO 150 JB = 1,NB RNORM(JB) = SNRM2(M-K,B(KP1,JB),1) 150 CONTINUE C C BACK SOLVE LOWER TRIANGULAR L C DO 170 JB = 1,NB DO 160 I = 1,K B(I,JB) = B(I,JB)/A(I,I) IF (I .EQ. K) GO TO 170 IP1 = I + 1 CALL SAXPY(K-I,-B(I,JB),A(IP1,I),1,B(IP1,JB),1) 160 CONTINUE 170 CONTINUE C C TRUNCATED SOLUTION C IF (K .EQ. N) GO TO 210 DO 201 JB = 1,NB DO 200 I = KP1,N B(I,JB) = 0.0 200 CONTINUE 201 CONTINUE C C APPLY HOUSEHOLDER TRANSFORMATIONS TO B C 210 DO 230 I = 1,K J = KP1 - I TT = A(J,J) A(J,J) = H(J) DO 220 JB = 1,NB BB = -SDOT(N-J+1,A(J,J),MDA,B(J,JB),1)/H(J) CALL SAXPY(N-J+1,BB,A(J,J),MDA,B(J,JB),1) 220 CONTINUE A(J,J) = TT 230 CONTINUE C C REORDER B TO REFLECT COLUMN INTERCHANGES C I = 0 C 240 I = I + 1 IF (I .EQ. N) GO TO 260 J = IC(I) IF (J .EQ. I) GO TO 240 IF (J .LT. 0) GO TO 240 C IC(I) = -IC(I) 250 CALL SSWAP (NB,B(J,1),MDB,B(I,1),MDB) IJ = IC(J) IC(J) = -IC(J) J = IJ IF (J .NE. I) GO TO 250 GO TO 240 C 260 DO 270 I = 1,N IC(I) = IABS(IC(I)) 270 CONTINUE RETURN END SUBROUTINE DLSQR (IND, A, MDA, M, N, B, MDB, NB, RE, AE, KRANK, * KSURE, RNORM, WORK, LW, IWORK, LIW, IERR) C----------------------------------------------------------------------- C C LEAST SQUARES SOLUTION OF LINEAR EQUATIONS C C -------------- C C DLSQR SOLVES BOTH UNDERDETERMINED AND OVERDETERMINED LINEAR C SYSTEMS AX = B, WHERE A IS AN M BY N MATRIX AND B IS AN M BY C NB MATRIX OF RIGHT HAND SIDES. IF M .GE. N, THE LEAST SQUARES C SOLUTION IS COMPUTED BY DECOMPOSING THE MATRIX A INTO THE C PRODUCT OF AN ORTHOGONAL MATRIX Q AND UPPER TRIANGULAR MATRIX C R (QR FACTORIZATION). IF M .LT. N, THE MINIMAL LENGTH SOLUTION C IS COMPUTED BY FACTORING THE MATRIX A INTO THE PRODUCT OF A C LOWER TRIANGULAR MATRIX L AND ORTHOGONAL MATRIX Q (LQ FACTOR- C IZATION). IF THE MATRIX A IS DETERMINED TO BE RANK DEFICIENT, C THEN THE MINIMAL LENGTH LEAST SQUARES SOLUTION IS COMPUTED. C C USER INPUT BOUNDS ON THE UNCERTAINTY OF THE ELEMENTS OF A ARE C USED TO DETECT NUMERICAL RANK DEFICIENCY. THE ALGORITHM USES C A ROW AND COLUMN PIVOT STRATEGY TO MINIMIZE THE GROWTH OF C UNCERTAINTY AND ROUND-OFF ERRORS. C C ****************************************************************** C * * C * WARNING - ALL INPUT ARRAYS ARE CHANGED ON EXIT. * C * * C ****************************************************************** C C INPUT.. C C IND INTEGER WHICH INDICATES IF THE ROUTINE IS BEING C CALLED FOR THE FIRST TIME. C IND = 0 ORIGINAL CALL C IND .NE. 0 SUBSEQUENT CALLS C ON SUBSEQUENT CALLS A NEW SET B OF EQUATIONS CAN C BE SOLVED (USING THE SAME COEFFICIENT MATRIX A). C IT IS ASSUMED THAT A, MDA, M, N, KRANK, IWORK, C LIW, AND THE FIRST 2*MIN(M,N) LOCATIONS OF WORK C HAVE NOT BEEN MODIFIED BY THE USER. RE, AE, AND C KSURE ARE NOT USED. C C A(,) LINEAR COEFFICIENT MATRIX OF AX=B, WITH MDA THE C MDA,M,N ACTUAL FIRST DIMENSION OF A IN THE CALLING PROGRAM. C M IS THE ROW DIMENSION (NO. OF EQUATIONS OF THE C PROBLEM) AND N THE COL DIMENSION (NO. OF UNKNOWNS). C MUST HAVE MDA .GE. M. C C B(,) RIGHT HAND SIDE(S), WITH MDB THE ACTUAL FIRST C MDB,NB DIMENSION OF B IN THE CALLING PROGRAM. NB IS THE C NUMBER OF M BY 1 RIGHT HAND SIDES. MUST HAVE C MDB .GE. MAX(M,N). IF NB .LE. 0 THEN B AND MDB C ARE IGNORED. C C RE RE IS THE MAXIMUM RELATIVE UNCERTAINTY OF THE C ELEMENTS OF THE MATRIX A (0 .LE. RE .LT. 1). C C AE AE IS THE MAXIMUM ABSOLUTE UNCERTAINTY OF THE C ELEMENTS OF THE MATRIX A (AE .GE. 0). C C WORK() A REAL WORK ARRAY DIMENSIONED 5*MIN(M,N). C C LW ACTUAL DIMENSION OF WORK C C IWORK() INTEGER WORK ARRAY DIMENSIONED AT LEAST N+M. C C LIW ACTUAL DIMENSION OF IWORK. C C OUTPUT.. C C A(,) CONTAINS THE TRIANGULAR PART OF THE REDUCED MATRIX C AND THE TRANSFORMATION INFORMATION.IND TOGETHER WITH C THE FIRST 2*MIN(M,N) ELEMENTS OF WORK (SEE BELOW) C COMPLETELY SPECIFY THE FACTORIZATION OF A. C C B(,) CONTAINS THE N BY NB SOLUTION MATRIX FOR X. C C KRANK,KSURE THE NUMERICAL RANK OF A, BASED UPON THE RELATIVE C AND ABSOLUTE BOUNDS ON UNCERTAINTY, IS BOUNDED C ABOVE BY KRANK AND BELOW BY KSURE. THE ALGORITHM C RETURNS A SOLUTION BASED ON KRANK. KSURE PROVIDES C AN INDICATION OF THE PRECISION OF THE RANK. C C RNORM() CONTAINS THE EUCLIDEAN LENGTH OF THE NB RESIDUAL C VECTORS B(I) - AX(I), I=1,...,NB. C C WORK() THE FIRST 2*MIN(M,N) LOCATIONS OF WORK CONTAIN C THE VALUES NECESSARY TO REPRODUCE THE HOUSEHOLDER C FACTORIZATION OF A. C C IWORK() AN ARRAY OF LENGTH M + N CONTAINING THE ORDERS IN C WHICH THE ROWS AND COLUMNS WERE USED. IF M .GE. N C THEN THE FIRST N LOCATIONS CONTAIN THE ORDER OF C THE COLUMNS AND THE NEXT M LOCATIONS THE ORDER OF C THE ROWS. IF M .LT. N THEN THE ORDER OF THE ROWS C PRECEDES THE ORDER OF THE COLUMNS. C C IERR FLAG TO INDICATE THE STATUS OF THE RESULTS C 0 - SATISFACTORY COMPLETION C .GT. 0 - INPUT ERROR C C---------------- C THE SUBROUTINES DU11LS, DU12LS, DU11US, AND DU12US WERE WRITTEN BY C T. MANTEUFFEL (LANL) IN 1981. THE DRIVER ROUTINE DLSQR WAS WRITTEN C BY A.H. MORRIS (NSWC) IN 1991. C---------------- C REFERENCE. MANTEUFFEL, T., *AN INTERVAL ANALYSIS APPROACH TO RANK C DETERMINATION IN LINEAR LEAST SQUARES PROBLEMS*, C SANDIA LABORATORIES REPORT SAND80-0655, JUNE, 1980. C----------------------------------------------------------------------- DOUBLE PRECISION A(MDA,N), B(MDB,*), RE, AE, RNORM(*), WORK(LW) INTEGER IWORK(LIW) DOUBLE PRECISION EPS, RERR DOUBLE PRECISION DPMPAR C---------------- C NP IF M .GE. N THEN THE FIRST NP COLUMNS OF A C ARE NEVER INTERCHANGED. C IF M .LT. N THEN THE FIRST NP ROWS OF A ARE C NEVER INTERCHANGED. NP IS NOT REFERENCED ON C A CONTINUATION CALL TO THE ROUTINE. C C MODE THE INTEGER MODE INDICATES HOW THE ROUTINE C IS TO REACT IF RANK DEFICIENCY IS DETECTED. C IF MODE = 0 RETURN IMMEDIATELY, NO SOLUTION C 1 COMPUTE TRUNCATED SOLUTION C 2 COMPUTE MINIMAL LENGTH SOLUTION C MODE MUST NOT BE MODIFIED ON A CONTINUATION C CALL TO THE ROUTINE. IF MODE LT. 2, ONLY THE C FIRST N LOCATIONS OF WORK ARE USED. C---------------- NP = 0 MODE = 2 C C CHECK THE INPUT C IF (NB .LE. 0 .AND. IND .NE. 0) GO TO 200 IF (M .LT. 1 .OR. N .LT. 1) GO TO 210 IF (MDA .LT. M) GO TO 220 IF (LIW .LT. M + N) GO TO 240 C M0 = MIN0(M,N) N0 = MAX0(M,N) C NUM = 0 C IF (NB .LE. 0) GO TO 10 IF (MDB .LT. N0) GO TO 230 IF (IND .NE. 0) GO TO 100 C 10 IF (LW .LT. 5*M0) GO TO 250 IF (RE .LT. 0.D0 .OR. AE .LT. 0.D0) GO TO 260 C C DEFINE THE RELATIVE AND ABSOLUTE TOLERANCE LISTS C M1 = 1 M2 = M1 + M0 M3 = M2 + M0 M4 = M3 + M0 M5 = M4 + M0 C EPS = 10.D0*DPMPAR(1) RERR = DMAX1(EPS,RE) C IMAX = M5 - 1 DO 20 I = M4,IMAX WORK(I) = RERR 20 CONTINUE IMAX = IMAX + M0 DO 30 I = M5,IMAX WORK(I) = AE 30 CONTINUE C C FACTOR THE MATRIX A C C NUM = NP IF (M .LT. N) GO TO 40 C CALL DU11LS (A,MDA,M,N,WORK(M4),WORK(M5),MODE,NP,KRANK,KSURE, * WORK(M1),WORK(M2),WORK(M3),IWORK(M1),IWORK(M2)) GO TO 100 C 40 CALL DU11US (A,MDA,M,N,WORK(M4),WORK(M5),MODE,NP,KRANK,KSURE, * WORK(M1),WORK(M2),WORK(M3),IWORK(M1),IWORK(M2)) C C SOLUTION PHASE C 100 IERR = 0 INFO = 0 IF (KRANK .EQ. M0) GO TO 110 IF (KRANK .EQ. 0) GO TO 110 C IF (KRANK .LT. NUM) GO TO 280 C IF (MODE .EQ. 0) RETURN INFO = MODE C 110 IF (NB .LE. 0) RETURN C M1 = 1 M2 = 1 + M0 IF (INFO .EQ. 2) GO TO 130 C C ONLY MIN(M,N) ELEMENTS OF WORK ARE NEEDED C IF (LW .LT. M0) GO TO 250 IF (M .LT. N) GO TO 120 C CALL DU12LS (A,MDA,M,N,B,MDB,NB,MODE,KRANK,RNORM, * WORK(M1),WORK(M1),IWORK(M1),IWORK(M2)) RETURN C 120 CALL DU12US (A,MDA,M,N,B,MDB,NB,MODE,KRANK,RNORM, * WORK(M1),WORK(M1),IWORK(M1),IWORK(M2)) RETURN C C HERE 2*MIN(M,N) ELEMENTS OF WORK ARE NEEDED C 130 IF (LW .LT. 2*M0) GO TO 250 IF (M .LT. N) GO TO 140 C CALL DU12LS (A,MDA,M,N,B,MDB,NB,MODE,KRANK,RNORM, * WORK(M1),WORK(M2),IWORK(M1),IWORK(M2)) RETURN C 140 CALL DU12US (A,MDA,M,N,B,MDB,NB,MODE,KRANK,RNORM, * WORK(M1),WORK(M2),IWORK(M1),IWORK(M2)) RETURN C C ERROR RETURN C C NB .LE. 0 ON A CONTINUATION CALL 200 IERR = 7 RETURN C M .LT. 1 OR N .LT. 1 210 IERR = 1 RETURN C MDA .LT. M 220 IERR = 2 RETURN C MDB .LT. MAX(M,N) 230 IERR = 3 RETURN C LIW .LT. M + N 240 IERR = 4 RETURN C LW TOO SMALL 250 IERR = 5 RETURN C RE OR AE IS NEGATIVE 260 IERR = 6 RETURN C 0 .LT. KRANK .LT. NP C 280 IERR = 8 C RETURN END SUBROUTINE DU11LS (A,MDA,M,N,UB,DB,MODE,NP,KRANK,KSURE,H,W,EB, * IC,IR) C C THIS ROUTINE PERFORMS A QR FACTORIZATION OF A C USING HOUSEHOLDER TRANSFORMATIONS. ROW AND C COLUMN PIVOTS ARE CHOSEN TO REDUCE THE GROWTH C OF ROUND-OFF AND TO HELP DETECT POSSIBLE RANK C DEFICIENCY. C DOUBLE PRECISION A(MDA,N), UB(N), DB(N), H(N), W(N), EB(N) INTEGER IC(N), IR(M) DOUBLE PRECISION BB, RMIN, R2, SUM, T, TEMP, TN, TT DOUBLE PRECISION DDOT, DNRM2 C C INITIALIZATION C J = 0 KRANK = N DO 10 I = 1,N IC(I) = I 10 CONTINUE DO 20 I = 1,M IR(I) = I 20 CONTINUE C C DETERMINE REL AND ABS ERROR VECTORS C C C CALCULATE COL LENGTH C DO 30 I = 1,N H(I) = DNRM2(M,A(1,I),1) W(I) = H(I) 30 CONTINUE C C INITIALIZE ERROR BOUNDS C DO 40 I = 1,N EB(I) = DMAX1(DB(I),UB(I)*H(I)) UB(I) = EB(I) DB(I) = 0.D0 40 CONTINUE C C DISCARD SELF DEPENDENT COLUMNS C I = 1 50 IF (EB(I) .GE. H(I)) GO TO 60 IF (I .EQ. KRANK) GO TO 70 I = I + 1 GO TO 50 C C MATRIX REDUCTION C 60 KK = KRANK KRANK = KRANK - 1 IF (MODE .EQ. 0) RETURN IF (I .LE. NP) GO TO 400 IF (I .GT. KRANK) GO TO 70 CALL DSWAP (1,EB(I),1,EB(KK),1) CALL DSWAP (1,UB(I),1,UB(KK),1) CALL DSWAP (1,W(I),1,W(KK),1) CALL DSWAP (1,H(I),1,H(KK),1) CALL ISWAP (1,IC(I),1,IC(KK),1) CALL DSWAP (M,A(1,I),1,A(1,KK),1) GO TO 50 C C TEST FOR ZERO RANK C 70 IF (KRANK .GT. 0) GO TO 100 KRANK = 0 KSURE = 0 RETURN C C M A I N L O O P C 100 J = J + 1 JP1 = J + 1 JM1 = J - 1 KZ = KRANK IF (J .LE. NP) KZ = J C C EACH COL HAS MM=M-J+1 COMPONENTS C MM = M - J + 1 C C UB DETERMINES COLUMN PIVOT C 110 IMIN = J IF (H(J) .EQ. 0.D0) GO TO 170 RMIN = UB(J)/H(J) DO 120 I = J,KZ IF (UB(I) .GE. H(I)*RMIN) GO TO 120 RMIN = UB(I)/H(I) IMIN = I 120 CONTINUE C C TEST FOR RANK DEFICIENCY C IF (RMIN .LT. 1.D0) GO TO 200 TT = (EB(IMIN) + DABS(DB(IMIN)))/H(IMIN) IF (TT .GE. 1.D0) GO TO 170 C C COMPUTE EXACT UB C DO 125 I = 1,JM1 W(I) = A(I,IMIN) 125 CONTINUE C L = JM1 130 W(L) = W(L)/A(L,L) IF (L .EQ. 1) GO TO 150 LM1 = L - 1 DO 140 I = L,JM1 W(LM1) = W(LM1) - A(LM1,I)*W(I) 140 CONTINUE L = LM1 GO TO 130 C 150 TT = EB(IMIN) DO 160 I = 1,JM1 TT = TT + DABS(W(I))*EB(I) 160 CONTINUE UB(IMIN) = TT IF (UB(IMIN)/H(IMIN) .GE. 1.D0) GO TO 170 GO TO 200 C C MATRIX REDUCTION C 170 KK = KRANK KRANK = KRANK - 1 KZ = KRANK IF (MODE .EQ. 0) RETURN IF (J .LE. NP) GO TO 410 IF (IMIN .GT. KRANK) GO TO 180 CALL ISWAP (1,IC(IMIN),1,IC(KK),1) CALL DSWAP (M,A(1,IMIN),1,A(1,KK),1) CALL DSWAP (1,EB(IMIN),1,EB(KK),1) CALL DSWAP (1,UB(IMIN),1,UB(KK),1) CALL DSWAP (1,DB(IMIN),1,DB(KK),1) CALL DSWAP (1,W(IMIN),1,W(KK),1) CALL DSWAP (1,H(IMIN),1,H(KK),1) 180 IF (J .GT. KRANK) GO TO 300 GO TO 110 C C COLUMN PIVOT C 200 IF (IMIN .EQ. J) GO TO 210 CALL DSWAP (1,H(J),1,H(IMIN),1) CALL DSWAP (M,A(1,J),1,A(1,IMIN),1) CALL DSWAP (1,EB(J),1,EB(IMIN),1) CALL DSWAP (1,UB(J),1,UB(IMIN),1) CALL DSWAP (1,DB(J),1,DB(IMIN),1) CALL DSWAP (1,W(J),1,W(IMIN),1) CALL ISWAP (1,IC(J),1,IC(IMIN),1) C C ROW PIVOT C 210 JMAX = IDAMAX(MM,A(J,J),1) JMAX = JMAX + J - 1 IF (JMAX .EQ. J) GO TO 220 CALL DSWAP (N,A(J,1),MDA,A(JMAX,1),MDA) CALL ISWAP (1,IR(J),1,IR(JMAX),1) C C APPLY HOUSEHOLDER TRANSFORMATION C 220 TN = DNRM2(MM,A(J,J),1) IF (TN .EQ. 0.D0) GO TO 170 IF (A(J,J) .NE. 0.D0) TN = DSIGN(TN,A(J,J)) CALL DSCAL (MM,1.D0/TN,A(J,J),1) A(J,J) = A(J,J) + 1.D0 IF (J .EQ. N) GO TO 250 DO 240 I = JP1,N BB = -DDOT(MM,A(J,J),1,A(J,I),1)/A(J,J) CALL DAXPY (MM,BB,A(J,J),1,A(J,I),1) IF (I .LE. NP) GO TO 240 IF (H(I) .EQ. 0.D0) GO TO 240 TT = 1.D0 - (A(J,I)/H(I))**2 TT = DMAX1(TT,0.D0) T = TT TT = 1.D0 + 0.05D0*TT*(H(I)/W(I))**2 IF (TT .EQ. 1.D0) GO TO 230 H(I) = H(I)*DSQRT(T) GO TO 240 230 H(I) = DNRM2(M-J,A(J+1,I),1) W(I) = H(I) 240 CONTINUE C 250 H(J) = A(J,J) A(J,J) = -TN C C UPDATE UB, DB C UB(J) = UB(J)/DABS(A(J,J)) DB(J) = (DSIGN(EB(J),DB(J)) + DB(J))/A(J,J) IF (J .EQ. KRANK) GO TO 300 DO 260 I = JP1,KRANK UB(I) = UB(I) + DABS(A(J,I))*UB(J) DB(I) = DB(I) - A(J,I)*DB(J) 260 CONTINUE GO TO 100 C C E N D M A I N L O O P C 300 CONTINUE C C COMPUTE KSURE C KM1 = KRANK - 1 DO 315 I = 1,KM1 IS = 0 KMI = KRANK - I DO 310 II = 1,KMI IF (UB(II) .LE. UB(II + 1)) GO TO 310 IS = 1 TEMP = UB(II) UB(II) = UB(II + 1) UB(II + 1) = TEMP 310 CONTINUE IF (IS .EQ. 0) GO TO 320 315 CONTINUE C 320 KSURE = 0 SUM = 0.D0 DO 325 I = 1,KRANK R2 = UB(I)*UB(I) IF (R2 + SUM .GE. 1.D0) GO TO 330 SUM = SUM + R2 KSURE = KSURE + 1 325 CONTINUE C C IF SYSTEM IS OF REDUCED RANK AND MODE = 2 C COMPLETE THE DECOMPOSITION FOR SHORTEST LEAST SQUARES SOLUTION C 330 IF (KRANK .EQ. N .OR. MODE .LT. 2) RETURN NMK = N - KRANK KP1 = KRANK + 1 I = KRANK 340 TN = DNRM2(NMK,A(I,KP1),MDA)/A(I,I) TN = A(I,I)*DSQRT(1.D0 + TN*TN) CALL DSCAL (NMK,1.D0/TN,A(I,KP1),MDA) W(I) = A(I,I)/TN + 1.D0 A(I,I) = -TN IF (I .EQ. 1) GO TO 350 IM1 = I - 1 DO 345 II = 1,IM1 TT = -DDOT(NMK,A(II,KP1),MDA,A(I,KP1),MDA)/W(I) TT = TT - A(II,I) CALL DAXPY (NMK,TT,A(I,KP1),MDA,A(II,KP1),MDA) A(II,I) = A(II,I) + TT*W(I) 345 CONTINUE I = I - 1 GO TO 340 C 350 CONTINUE RETURN C C FIRST NP COLUMNS ARE LINEARLY DEPENDENT C 400 KRANK = I - 1 RETURN 410 KRANK = J - 1 RETURN END SUBROUTINE DU12LS (A,MDA,M,N,B,MDB,NB,MODE,KRANK,RNORM,H,W,IC,IR) C C GIVEN THE HOUSEHOLDER QR FACTORIZATION OF A, THIS C SUBROUTINE SOLVES THE SYSTEM AX=B. IF THE SYSTEM C IS OF REDUCED RANK, THIS ROUTINE RETURNS A SOLUTION C ACCORDING TO THE SELECTED MODE. C C NOTE - IF MODE.NE.2, W IS NEVER ACCESSED. C DOUBLE PRECISION A(MDA,N), B(MDB,NB), RNORM(NB), H(N), W(N) INTEGER IC(N), IR(M) DOUBLE PRECISION BB, TT DOUBLE PRECISION DDOT, DNRM2 C K = KRANK KP1 = K + 1 IF (K .GT. 0) GO TO 30 C C RANK=0 C DO 10 JB = 1,NB RNORM(JB) = DNRM2(M,B(1,JB),1) 10 CONTINUE DO 21 JB = 1,NB DO 20 I = 1,N B(I,JB) = 0.D0 20 CONTINUE 21 CONTINUE RETURN C 30 I = 0 C C REORDER B TO REFLECT ROW INTERCHANGES C 40 I = I + 1 IF (I .EQ. M) GO TO 100 J = IR(I) IF (J .EQ. I) GO TO 40 IF (J .LT. 0) GO TO 40 C IR(I) = -IR(I) DO 50 JB = 1,NB RNORM(JB) = B(I,JB) 50 CONTINUE C IJ = I 60 DO 70 JB = 1,NB B(IJ,JB) = B(J,JB) 70 CONTINUE IJ = J J = IR(IJ) IR(IJ) = -IR(IJ) IF (J .NE. I) GO TO 60 C DO 80 JB = 1,NB B(IJ,JB) = RNORM(JB) 80 CONTINUE GO TO 40 C 100 DO 110 I = 1,M IR(I) = IABS(IR(I)) 110 CONTINUE C C APPLY HOUSEHOLDER TRANSFORMATIONS TO B C DO 130 J = 1,K TT = A(J,J) A(J,J) = H(J) DO 120 I = 1,NB BB = -DDOT (M-J+1,A(J,J),1,B(J,I),1)/H(J) CALL DAXPY (M-J+1,BB,A(J,J),1,B(J,I),1) 120 CONTINUE A(J,J) = TT 130 CONTINUE C C FIND NORMS OF RESIDUAL VECTOR(S)..(BEFORE OVERWRITE B) C DO 140 JB = 1,NB RNORM(JB) = DNRM2(M-K,B(KP1,JB),1) 140 CONTINUE C C BACK SOLVE UPPER TRIANGULAR R C I = K 150 DO 160 JB = 1,NB B(I,JB) = B(I,JB)/A(I,I) 160 CONTINUE IF (I .EQ. 1) GO TO 200 IM1 = I - 1 DO 170 JB = 1,NB CALL DAXPY (IM1,-B(I,JB),A(1,I),1,B(1,JB),1) 170 CONTINUE I = IM1 GO TO 150 C C RANK LT N C C TRUNCATED SOLUTION C 200 IF (K .EQ. N) GO TO 230 DO 211 JB = 1,NB DO 210 I = KP1,N B(I,JB) = 0.D0 210 CONTINUE 211 CONTINUE IF (MODE .EQ. 1) GO TO 230 C C MINIMAL LENGTH SOLUTION C NMK = N - K DO 221 JB = 1,NB DO 220 I = 1,K TT = -DDOT(NMK,A(I,KP1),MDA,B(KP1,JB),1)/W(I) TT = TT - B(I,JB) CALL DAXPY (NMK,TT,A(I,KP1),MDA,B(KP1,JB),1) B(I,JB) = B(I,JB) + TT*W(I) 220 CONTINUE 221 CONTINUE C C REORDER B TO REFLECT COLUMN INTERCHANGES C 230 I = 0 C 240 I = I + 1 IF (I .EQ. N) GO TO 260 J = IC(I) IF (J .EQ. I) GO TO 240 IF (J .LT. 0) GO TO 240 C IC(I) = -IC(I) 250 CALL DSWAP (NB,B(J,1),MDB,B(I,1),MDB) IJ = IC(J) IC(J) = -IC(J) J = IJ IF (J .NE. I) GO TO 250 GO TO 240 C 260 DO 270 I = 1,N IC(I) = IABS(IC(I)) 270 CONTINUE RETURN END SUBROUTINE DU11US (A,MDA,M,N,UB,DB,MODE,NP,KRANK,KSURE,H,W,EB, * IR,IC) C C THIS ROUTINE PERFORMS AN LQ FACTORIZATION OF THE C MATRIX A USING HOUSEHOLDER TRANSFORMATIONS. ROW C AND COLUMN PIVOTS ARE CHOSEN TO REDUCE THE GROWTH C OF ROUND-OFF AND TO HELP DETECT POSSIBLE RANK C DEFICIENCY. C DOUBLE PRECISION A(MDA,N), UB(M), DB(M), H(M), W(M), EB(M) INTEGER IC(N), IR(M) DOUBLE PRECISION BB, RMIN, R2, SUM, T, TEMP, TN, TT DOUBLE PRECISION DDOT, DNRM2 C C INITIALIZATION C J = 0 KRANK = M DO 10 I = 1,N IC(I) = I 10 CONTINUE DO 20 I = 1,M IR(I) = I 20 CONTINUE C C DETERMINE REL AND ABS ERROR VECTORS C C C CALCULATE ROW LENGTH C DO 30 I = 1,M H(I) = DNRM2(N,A(I,1),MDA) W(I) = H(I) 30 CONTINUE C C INITIALIZE ERROR BOUNDS C DO 40 I = 1,M EB(I) = DMAX1(DB(I),UB(I)*H(I)) UB(I) = EB(I) DB(I) = 0.D0 40 CONTINUE C C DISCARD SELF DEPENDENT ROWS C I = 1 50 IF (EB(I) .GE. H(I)) GO TO 60 IF (I .EQ. KRANK) GO TO 70 I = I + 1 GO TO 50 C C MATRIX REDUCTION C 60 KK = KRANK KRANK = KRANK - 1 IF (MODE .EQ. 0) RETURN IF (I .LE. NP) GO TO 400 IF (I .GT. KRANK) GO TO 70 CALL DSWAP (1,EB(I),1,EB(KK),1) CALL DSWAP (1,UB(I),1,UB(KK),1) CALL DSWAP (1,W(I),1,W(KK),1) CALL DSWAP (1,H(I),1,H(KK),1) CALL ISWAP (1,IR(I),1,IR(KK),1) CALL DSWAP (N,A(I,1),MDA,A(KK,1),MDA) GO TO 50 C C TEST FOR ZERO RANK C 70 IF (KRANK .GT. 0) GO TO 100 KRANK = 0 KSURE = 0 RETURN C C M A I N L O O P C 100 J = J + 1 JP1 = J + 1 JM1 = J - 1 KZ = KRANK IF (J .LE. NP) KZ = J C C EACH ROW HAS NN=N-J+1 COMPONENTS C NN = N - J + 1 C C UB DETERMINES ROW PIVOT C 110 IMIN = J IF (H(J) .EQ. 0.D0) GO TO 170 RMIN = UB(J)/H(J) DO 120 I = J,KZ IF (UB(I) .GE. H(I)*RMIN) GO TO 120 RMIN = UB(I)/H(I) IMIN = I 120 CONTINUE C C TEST FOR RANK DEFICIENCY C IF (RMIN .LT. 1.D0) GO TO 200 TT = (EB(IMIN) + DABS(DB(IMIN)))/H(IMIN) IF (TT .GE. 1.D0) GO TO 170 C C COMPUTE EXACT UB C DO 125 I = 1,JM1 W(I) = A(IMIN,I) 125 CONTINUE C L = JM1 130 W(L) = W(L)/A(L,L) IF (L .EQ. 1) GO TO 150 LM1 = L - 1 DO 140 I = L,JM1 W(LM1) = W(LM1) - A(I,LM1)*W(I) 140 CONTINUE L = LM1 GO TO 130 C 150 TT = EB(IMIN) DO 160 I = 1,JM1 TT = TT + DABS(W(I))*EB(I) 160 CONTINUE UB(IMIN) = TT IF (UB(IMIN)/H(IMIN) .GE. 1.D0) GO TO 170 GO TO 200 C C MATRIX REDUCTION C 170 KK = KRANK KRANK = KRANK - 1 KZ = KRANK IF (MODE .EQ. 0) RETURN IF (J .LE. NP) GO TO 410 IF (IMIN .GT. KRANK) GO TO 180 CALL ISWAP (1,IR(IMIN),1,IR(KK),1) CALL DSWAP (N,A(IMIN,1),MDA,A(KK,1),MDA) CALL DSWAP (1,EB(IMIN),1,EB(KK),1) CALL DSWAP (1,UB(IMIN),1,UB(KK),1) CALL DSWAP (1,DB(IMIN),1,DB(KK),1) CALL DSWAP (1,W(IMIN),1,W(KK),1) CALL DSWAP (1,H(IMIN),1,H(KK),1) 180 IF (J .GT. KRANK) GO TO 300 GO TO 110 C C ROW PIVOT C 200 IF (IMIN .EQ. J) GO TO 210 CALL DSWAP (1,H(J),1,H(IMIN),1) CALL DSWAP (N,A(J,1),MDA,A(IMIN,1),MDA) CALL DSWAP (1,EB(J),1,EB(IMIN),1) CALL DSWAP (1,UB(J),1,UB(IMIN),1) CALL DSWAP (1,DB(J),1,DB(IMIN),1) CALL DSWAP (1,W(J),1,W(IMIN),1) CALL ISWAP (1,IR(J),1,IR(IMIN),1) C C COLUMN PIVOT C 210 JMAX = IDAMAX(NN,A(J,J),MDA) JMAX = JMAX + J - 1 IF (JMAX .EQ. J) GO TO 220 CALL DSWAP (M,A(1,J),1,A(1,JMAX),1) CALL ISWAP (1,IC(J),1,IC(JMAX),1) C C APPLY HOUSEHOLDER TRANSFORMATION C 220 TN = DNRM2(NN,A(J,J),MDA) IF (TN .EQ. 0.D0) GO TO 170 IF (A(J,J) .NE. 0.D0) TN = DSIGN(TN,A(J,J)) CALL DSCAL (NN,1.D0/TN,A(J,J),MDA) A(J,J) = A(J,J) + 1.D0 IF (J .EQ. M) GO TO 250 DO 240 I = JP1,M BB = -DDOT(NN,A(J,J),MDA,A(I,J),MDA)/A(J,J) CALL DAXPY (NN,BB,A(J,J),MDA,A(I,J),MDA) IF (I .LE. NP) GO TO 240 IF (H(I) .EQ. 0.D0) GO TO 240 TT = 1.0 - (A(I,J)/H(I))**2 TT = DMAX1(TT,0.D0) T = TT TT = 1.D0 + 0.05D0*TT*(H(I)/W(I))**2 IF (TT .EQ. 1.D0) GO TO 230 H(I) = H(I)*DSQRT(T) GO TO 240 230 H(I) = DNRM2(N-J,A(I,J+1),MDA) W(I) = H(I) 240 CONTINUE C 250 H(J) = A(J,J) A(J,J) = -TN C C UPDATE UB, DB C UB(J) = UB(J)/DABS(A(J,J)) DB(J) = (DSIGN(EB(J),DB(J)) + DB(J))/A(J,J) IF (J .EQ. KRANK) GO TO 300 DO 260 I = JP1,KRANK UB(I) = UB(I) + DABS(A(I,J))*UB(J) DB(I) = DB(I) - A(I,J)*DB(J) 260 CONTINUE GO TO 100 C C E N D M A I N L O O P C 300 CONTINUE C C COMPUTE KSURE C KM1 = KRANK - 1 DO 315 I = 1,KM1 IS = 0 KMI = KRANK - I DO 310 II = 1,KMI IF (UB(II) .LE. UB(II + 1)) GO TO 310 IS = 1 TEMP = UB(II) UB(II) = UB(II + 1) UB(II + 1) = TEMP 310 CONTINUE IF (IS .EQ. 0) GO TO 320 315 CONTINUE C 320 KSURE = 0 SUM = 0.D0 DO 325 I = 1,KRANK R2 = UB(I)*UB(I) IF (R2 + SUM .GE. 1.D0) GO TO 330 SUM = SUM + R2 KSURE = KSURE + 1 325 CONTINUE C C IF SYSTEM IS OF REDUCED RANK AND MODE = 2 C COMPLETE THE DECOMPOSITION FOR SHORTEST LEAST SQUARES SOLUTION C 330 IF (KRANK .EQ. M .OR. MODE .LT. 2) RETURN MMK = M - KRANK KP1 = KRANK + 1 I = KRANK 340 TN = DNRM2(MMK,A(KP1,I),1)/A(I,I) TN = A(I,I)*DSQRT(1.D0 + TN*TN) CALL DSCAL (MMK,1.D0/TN,A(KP1,I),1) W(I) = A(I,I)/TN + 1.D0 A(I,I) = -TN IF (I .EQ. 1) GO TO 350 IM1 = I - 1 DO 345 II = 1,IM1 TT = -DDOT(MMK,A(KP1,II),1,A(KP1,I),1)/W(I) TT = TT - A(I,II) CALL DAXPY (MMK,TT,A(KP1,I),1,A(KP1,II),1) A(I,II) = A(I,II) + TT*W(I) 345 CONTINUE I = I - 1 GO TO 340 C 350 CONTINUE RETURN C C FIRST NP ROWS ARE LINEARLY DEPENDENT C 400 KRANK = I - 1 RETURN 410 KRANK = J - 1 RETURN END SUBROUTINE DU12US (A,MDA,M,N,B,MDB,NB,MODE,KRANK,RNORM,H,W,IR,IC) C C GIVEN THE HOUSEHOLDER LQ FACTORIZATION OF A, THIS C SUBROUTINE SOLVES THE SYSTEM AX=B. IF THE SYSTEM C IS OF REDUCED RANK, THIS ROUTINE RETURNS A SOLUTION C ACCORDING TO THE SELECTED MODE. C C NOTE - IF MODE.NE.2, W IS NEVER ACCESSED. C DOUBLE PRECISION A(MDA,N), B(MDB,NB), RNORM(NB), H(M), W(M) INTEGER IC(N), IR(M) DOUBLE PRECISION BB, TT DOUBLE PRECISION DDOT, DNRM2 C K = KRANK KP1 = K + 1 IF (K .GT. 0) GO TO 30 C C RANK=0 C DO 10 JB = 1,NB RNORM(JB) = DNRM2(M,B(1,JB),1) 10 CONTINUE DO 21 JB = 1,NB DO 20 I = 1,N B(I,JB) = 0.D0 20 CONTINUE 21 CONTINUE RETURN C 30 I = 0 C C REORDER B TO REFLECT ROW INTERCHANGES C 40 I = I + 1 IF (I .EQ. M) GO TO 100 J = IR(I) IF (J .EQ. I) GO TO 40 IF (J .LT. 0) GO TO 40 C IR(I) = -IR(I) DO 50 JB = 1,NB RNORM(JB) = B(I,JB) 50 CONTINUE C IJ = I 60 DO 70 JB = 1,NB B(IJ,JB) = B(J,JB) 70 CONTINUE IJ = J J = IR(IJ) IR(IJ) = -IR(IJ) IF (J .NE. I) GO TO 60 C DO 80 JB = 1,NB B(IJ,JB) = RNORM(JB) 80 CONTINUE GO TO 40 C 100 DO 110 I = 1,M IR(I) = IABS(IR(I)) 110 CONTINUE C C IF A IS OF REDUCED RANK AND MODE=2, C APPLY HOUSEHOLDER TRANSFORMATIONS TO B C IF (MODE .LT. 2 .OR. K .EQ. M) GO TO 140 MMK = M - K DO 130 JB = 1,NB DO 120 J = 1,K I = KP1 - J TT = -DDOT(MMK,A(KP1,I),1,B(KP1,JB),1)/W(I) TT = TT - B(I,JB) CALL DAXPY (MMK,TT,A(KP1,I),1,B(KP1,JB),1) B(I,JB) = B(I,JB) + TT*W(I) 120 CONTINUE 130 CONTINUE C C FIND NORMS OF RESIDUAL VECTOR(S)..(BEFORE OVERWRITE B) C 140 DO 150 JB = 1,NB RNORM(JB) = DNRM2(M-K,B(KP1,JB),1) 150 CONTINUE C C BACK SOLVE LOWER TRIANGULAR L C DO 170 JB = 1,NB DO 160 I = 1,K B(I,JB) = B(I,JB)/A(I,I) IF (I .EQ. K) GO TO 170 IP1 = I + 1 CALL DAXPY(K-I,-B(I,JB),A(IP1,I),1,B(IP1,JB),1) 160 CONTINUE 170 CONTINUE C C TRUNCATED SOLUTION C IF (K .EQ. N) GO TO 210 DO 201 JB = 1,NB DO 200 I = KP1,N B(I,JB) = 0.D0 200 CONTINUE 201 CONTINUE C C APPLY HOUSEHOLDER TRANSFORMATIONS TO B C 210 DO 230 I = 1,K J = KP1 - I TT = A(J,J) A(J,J) = H(J) DO 220 JB = 1,NB BB = -DDOT(N-J+1,A(J,J),MDA,B(J,JB),1)/H(J) CALL DAXPY(N-J+1,BB,A(J,J),MDA,B(J,JB),1) 220 CONTINUE A(J,J) = TT 230 CONTINUE C C REORDER B TO REFLECT COLUMN INTERCHANGES C I = 0 C 240 I = I + 1 IF (I .EQ. N) GO TO 260 J = IC(I) IF (J .EQ. I) GO TO 240 IF (J .LT. 0) GO TO 240 C IC(I) = -IC(I) 250 CALL DSWAP (NB,B(J,1),MDB,B(I,1),MDB) IJ = IC(J) IC(J) = -IC(J) J = IJ IF (J .NE. I) GO TO 250 GO TO 240 C 260 DO 270 I = 1,N IC(I) = IABS(IC(I)) 270 CONTINUE RETURN END SUBROUTINE HFTI (A,MDA,M,N,B,MDB,NB,TAU,K,RNORM,H,G,IP) C----------------------------------------------------------------------- C DIMENSION A(MDA,N),(B(MDB,NB) OR B(M)),RNORM(NB),H(N),G(N),IP(N) C C WRITTEN BY C.L. LAWSON AND R.J. HANSON. C FROM THE BOOK SOLVING LEAST SQUARES PROBLEMS, PRENTICE-HALL, 1974. C FOR ALGORITHMIC DETAILS SEE ALGORITHM HFTI IN CHAPTER 14. C C ABSTRACT C C THIS SUBROUTINE SOLVES A LINEAR LEAST SQUARES PROBLEM OR A SET OF C LINEAR LEAST SQUARES PROBLEMS HAVING THE SAME MATRIX BUT DIFFERENT C RIGHT-SIDE VECTORS. THE PROBLEM DATA CONSISTS OF AN M BY N MATRIX C A, AN M BY NB MATRIX B, AND AN ABSOLUTE TOLERANCE PARAMETER TAU C WHOSE USAGE IS DESCRIBED BELOW. THE NB COLUMN VECTORS OF B C REPRESENT RIGHT-SIDE VECTORS FOR NB DISTINCT LINEAR LEAST SQUARES C PROBLEMS. C C THIS SET OF PROBLEMS CAN ALSO BE WRITTEN AS THE MATRIX LEAST C SQUARES PROBLEM C C AX = B, C C WHERE X IS THE N BY NB SOLUTION MATRIX. C C NOTE THAT IF B IS THE M BY M IDENTITY MATRIX, THEN X WILL BE THE C PSEUDO-INVERSE OF A. C C THIS SUBROUTINE FIRST TRANSFORMS THE AUGMENTED MATRIX (A B) TO A C MATRIX (R C) USING PREMULTIPLYING HOUSEHOLDER TRANSFORMATIONS WITH C COLUMN INTERCHANGES. ALL SUBDIAGONAL ELEMENTS IN THE MATRIX R ARE C ZERO AND ITS DIAGONAL ELEMENTS SATISFY C C ABS(R(I,I)).GE.ABS(R(I+1,I+1)), C C I = 1,...,L-1, WHERE C C L = MIN(M,N). C C THE SUBROUTINE SETS K TO BE THE NUMBER OF DIAGONAL ELEMENTS C OF R THAT EXCEED TAU IN MAGNITUDE. THEN THE SOLUTION OF MINIMUM C EUCLIDEAN LENGTH IS COMPUTED USING THE FIRST K ROWS OF (R C). C C TO BE SPECIFIC WE SUGGEST THAT THE USER CONSIDER AN EASILY C COMPUTABLE MATRIX NORM, SUCH AS, THE MAXIMUM OF ALL COLUMN SUMS OF C MAGNITUDES. C C NOW IF THE RELATIVE UNCERTAINTY OF B IS EPS, (NORM OF UNCERTAINTY/ C NORM OF B), IT IS SUGGESTED THAT TAU BE SET APPROXIMATELY EQUAL TO C EPS*(NORM OF A). C C THE ENTIRE SET OF PARAMETERS FOR HFTI ARE C C INPUT.. C C A(*,*),MDA,M,N THE ARRAY A(*,*) INITIALLY CONTAINS THE M BY N C MATRIX A OF THE LEAST SQUARES PROBLEM AX = B. C THE FIRST DIMENSIONING PARAMETER OF THE ARRAY C A(*,*) IS MDA, WHICH MUST SATISFY MDA.GE.M C EITHER M.GE.N OR M.LT.N IS PERMITTED. THERE C IS NO RESTRICTION ON THE RANK OF A. THE C CONDITION MDA.LT.M IS CONSIDERED AN ERROR. C C B(*),MDB,NB IF NB = 0 THE SUBROUTINE WILL PERFORM THE C ORTHOGONAL DECOMPOSITION BUT WILL MAKE NO C REFERENCES TO THE ARRAY B(*). IF NB.GT.0 C THE ARRAY B(*) MUST INITIALLY CONTAIN THE M BY C NB MATRIX B OF THE LEAST SQUARES PROBLEM AX = C B. IF NB.GE.2 THE ARRAY B(*) MUST BE DOUBLY C SUBSCRIPTED WITH FIRST DIMENSIONING PARAMETER C MDB.GE.MAX(M,N). IF NB = 1 THE ARRAY B(*) MAY C BE EITHER DOUBLY OR SINGLY SUBSCRIPTED. IN C THE LATTER CASE THE VALUE OF MDB IS ARBITRARY C BUT IT SHOULD BE SET TO SOME VALID INTEGER C VALUE SUCH AS MDB = M. C C THE CONDITION OF NB.GT.1.AND.MDB.LT. MAX(M,N) C IS CONSIDERED AN ERROR. C C TAU ABSOLUTE TOLERANCE PARAMETER PROVIDED BY USER C FOR PSEUDORANK DETERMINATION. C C H(*),G(*),IP(*) ARRAYS OF WORKING SPACE USED BY HFTI. C C OUTPUT.. C C A(*,*) THE CONTENTS OF THE ARRAY A(*,*) WILL BE C MODIFIED BY THE SUBROUTINE. THESE CONTENTS C ARE NOT GENERALLY REQUIRED BY THE USER. C C B(*) ON RETURN THE ARRAY B(*) WILL CONTAIN THE N BY C NB SOLUTION MATRIX X. C C K SET BY THE SUBROUTINE TO INDICATE THE C PSEUDORANK OF A. C C RNORM(*) ON RETURN, RNORM(J) WILL CONTAIN THE EUCLIDEAN C NORM OF THE RESIDUAL VECTOR FOR THE PROBLEM C DEFINED BY THE J-TH COLUMN VECTOR OF THE ARRAY C B(*,*) FOR J = 1,...,NB. C C H(*),G(*) ON RETURN THESE ARRAYS RESPECTIVELY CONTAIN C ELEMENTS OF THE PRE- AND POST-MULTIPLYING C HOUSEHOLDER TRANSFORMATIONS USED TO COMPUTE C THE MINIMUM EUCLIDEAN LENGTH SOLUTION. C C IP(*) ARRAY IN WHICH THE SUBROUTINE RECORDS INDICES C DESCRIBING THE PERMUTATION OF COLUMN VECTORS. C THE CONTENTS OF ARRAYS H(*),G(*) AND IP(*) C ARE NOT GENERALLY REQUIRED BY THE USER. C----------------------------------------------------------------------- DIMENSION A(MDA,N),B(MDB,*),RNORM(*),H(N),G(N) INTEGER IP(N) DOUBLE PRECISION SM C--------------------- DATA FACTOR /1.E-3/ C K = 0 LDIAG = MIN0(M,N) IF (LDIAG .LE. 0) GO TO 270 DO 80 J = 1,LDIAG IF (J .EQ. 1) GO TO 20 C C UPDATE SQUARED COLUMN LENGTHS AND FIND LMAX C .. LMAX = J DO 10 L = J,N H(L) = H(L) - A(J-1,L)**2 IF (H(L) .GT. H(LMAX)) LMAX = L 10 CONTINUE Z = HMAX + FACTOR*H(LMAX) IF (Z .GT. HMAX) GO TO 50 C C COMPUTE SQUARED COLUMN LENGTHS AND FIND LMAX C .. 20 LMAX=J DO 40 L = J,N H(L) = 0.0 DO 30 I = J,M 30 H(L) = H(L) + A(I,L)**2 IF (H(L) .GT. H(LMAX)) LMAX = L 40 CONTINUE HMAX = H(LMAX) C .. C LMAX HAS BEEN DETERMINED C C DO COLUMN INTERCHANGES IF NEEDED. C .. 50 IP(J) = LMAX IF (IP(J) .EQ. J) GO TO 70 DO 60 I = 1,M TMP = A(I,J) A(I,J) = A(I,LMAX) 60 A(I,LMAX) = TMP H(LMAX) = H(J) C C COMPUTE THE J-TH TRANSFORMATION AND APPLY IT TO A AND B. C .. 70 CALL H12 (1,J,J+1,M,A(1,J),1,H(J),A(1,J+1),1,MDA,N-J) 80 CALL H12 (2,J,J+1,M,A(1,J),1,H(J),B,1,MDB,NB) C C DETERMINE THE PSEUDORANK, K, USING THE TOLERANCE, TAU. C .. DO 90 J = 1,LDIAG IF (ABS(A(J,J)) .LE. TAU) GO TO 100 90 CONTINUE K = LDIAG GO TO 110 100 K = J - 1 110 KP1 = K + 1 C C COMPUTE THE NORMS OF THE RESIDUAL VECTORS. C IF (NB .LE. 0) GO TO 140 DO 130 JB = 1,NB TMP = 0.0 IF (KP1 .GT. M) GO TO 130 DO 120 I = KP1,M 120 TMP = TMP + B(I,JB)**2 130 RNORM(JB) = SQRT(TMP) 140 CONTINUE C SPECIAL FOR PSEUDORANK = 0 IF (K .GT. 0) GO TO 160 IF (NB .LE. 0) GO TO 270 DO 151 JB = 1,NB DO 150 I = 1,N 150 B(I,JB) = 0.0 151 CONTINUE GO TO 270 C C IF THE PSEUDORANK IS LESS THAN N COMPUTE HOUSEHOLDER C DECOMPOSITION OF FIRST K ROWS. C .. 160 IF (K .EQ. N) GO TO 180 DO 170 II = 1,K I = KP1 - II 170 CALL H12 (1,I,KP1,N,A(I,1),MDA,G(I),A,MDA,1,I-1) 180 CONTINUE C C IF (NB .LE. 0) GO TO 270 DO 260 JB = 1,NB C C SOLVE THE K BY K TRIANGULAR SYSTEM. C .. DO 210 L = 1,K SM = 0.D0 I = KP1 - L IF (I .EQ. K) GO TO 200 IP1 = I + 1 DO 190 J = IP1,K 190 SM = SM + DBLE(A(I,J))*DBLE(B(J,JB)) 200 SM1 = DBLE(B(I,JB)) - SM 210 B(I,JB) = SM1/A(I,I) C C COMPLETE COMPUTATION OF SOLUTION VECTOR. C .. IF (K .EQ. N) GO TO 240 DO 220 J = KP1,N 220 B(J,JB) = 0.0 DO 230 I = 1,K 230 CALL H12 (2,I,KP1,N,A(I,1),MDA,G(I),B(1,JB),1,MDB,1) C C RE-ORDER THE SOLUTION VECTOR TO COMPENSATE FOR THE C COLUMN INTERCHANGES. C .. 240 DO 250 JJ = 1,LDIAG J = LDIAG + 1 - JJ IF (IP(J) .EQ. J) GO TO 250 L = IP(J) TMP = B(L,JB) B(L,JB) = B(J,JB) B(J,JB) = TMP 250 CONTINUE 260 CONTINUE C .. C THE SOLUTION VECTORS, X, ARE NOW C IN THE FIRST N ROWS OF THE ARRAY B(,). C 270 RETURN END SUBROUTINE HFTI2(A,MDA,M,N,B,MDB,NB,D,TAU,K,RNORM,H,G,IP,IERR) C----------------------------------------------------------------------- C DIMENSION A(MDA,N),(B(MDB,NB) OR B(M)) C DIMENSION D(L) WHERE L = MIN(M,N) C DIMENSION RNORM(NB),H(N),G(N),IP(N) C C WRITTEN BY C.L. LAWSON AND R.J. HANSON. MODIFIED BY A.H. MORRIS. C FROM THE BOOK SOLVING LEAST SQUARES PROBLEMS, PRENTICE-HALL, 1974. C FOR ALGORITHMIC DETAILS SEE ALGORITHM HFTI IN CHAPTER 14. C C ABSTRACT C C THIS SUBROUTINE SOLVES A LINEAR LEAST SQUARES PROBLEM OR A SET OF C LINEAR LEAST SQUARES PROBLEMS HAVING THE SAME MATRIX BUT DIFFERENT C RIGHT-SIDE VECTORS. THE PROBLEM DATA CONSISTS OF AN M BY N MATRIX C A, AN M BY NB MATRIX B, AND AN ABSOLUTE TOLERANCE PARAMETER TAU C WHOSE USAGE IS DESCRIBED BELOW. THE NB COLUMN VECTORS OF B C REPRESENT RIGHT-SIDE VECTORS FOR NB DISTINCT LINEAR LEAST SQUARES C PROBLEMS. C C THIS SET OF PROBLEMS CAN ALSO BE WRITTEN AS THE MATRIX LEAST C SQUARES PROBLEM C C AX = B, C C WHERE X IS THE N BY NB SOLUTION MATRIX. C C NOTE THAT IF B IS THE M BY M IDENTITY MATRIX, THEN X WILL BE THE C PSEUDO-INVERSE OF A. C C THIS SUBROUTINE FIRST TRANSFORMS THE AUGMENTED MATRIX (A B) TO A C MATRIX (R C) USING PREMULTIPLYING HOUSEHOLDER TRANSFORMATIONS WITH C COLUMN INTERCHANGES. ALL SUBDIAGONAL ELEMENTS IN THE MATRIX R ARE C ZERO AND ITS DIAGONAL ELEMENTS SATISFY C C ABS(R(I,I)).GE.ABS(R(I+1,I+1)), C C I = 1,...,L-1, WHERE C C L = MIN(M,N). C C THE ARRAY D WILL CONTAIN THE DIAGONAL ELEMENTS R(1,1),...,R(L,L). C THE SUBROUTINE SETS K TO BE THE NUMBER OF DIAGONAL ELEMENTS THAT C EXCEED TAU IN MAGNITUDE. THEN THE SOLUTION OF MINIMUM EUCLIDEAN C LENGTH IS COMPUTED USING THE FIRST K ROWS OF (R C). C C TO BE SPECIFIC WE SUGGEST THAT THE USER CONSIDER AN EASILY C COMPUTABLE MATRIX NORM, SUCH AS, THE MAXIMUM OF ALL COLUMN SUMS OF C MAGNITUDES. C C NOW IF THE RELATIVE UNCERTAINTY OF B IS EPS, (NORM OF UNCERTAINTY/ C NORM OF B), IT IS SUGGESTED THAT TAU BE SET APPROXIMATELY EQUAL TO C EPS*(NORM OF A). C C THE ENTIRE SET OF PARAMETERS FOR HFTI2 ARE C C INPUT.. C C A(*,*),MDA,M,N THE ARRAY A(*,*) INITIALLY CONTAINS THE M BY N C MATRIX A OF THE LEAST SQUARES PROBLEM AX = B. C THE FIRST DIMENSIONING PARAMETER OF THE ARRAY C A(*,*) IS MDA, WHICH MUST SATISFY MDA.GE.M C EITHER M.GE.N OR M.LT.N IS PERMITTED. THERE C IS NO RESTRICTION ON THE RANK OF A. THE C CONDITION MDA.LT.M IS CONSIDERED AN ERROR. C C B(*),MDB,NB IF NB = 0 THE SUBROUTINE WILL PERFORM THE C ORTHOGONAL DECOMPOSITION BUT WILL MAKE NO C REFERENCES TO THE ARRAY B(*). IF NB.GT.0 C THE ARRAY B(*) MUST INITIALLY CONTAIN THE M BY C NB MATRIX B OF THE LEAST SQUARES PROBLEM AX = C B. IF NB.GE.2 THE ARRAY B(*) MUST BE DOUBLY C SUBSCRIPTED WITH FIRST DIMENSIONING PARAMETER C MDB.GE.MAX(M,N). IF NB = 1 THE ARRAY B(*) MAY C BE EITHER DOUBLY OR SINGLY SUBSCRIPTED. IN C THE LATTER CASE THE VALUE OF MDB IS ARBITRARY C BUT IT SHOULD BE SET TO SOME VALID INTEGER C VALUE SUCH AS MDB = M. C C THE CONDITION OF NB.GT.1.AND.MDB.LT. MAX(M,N) C IS CONSIDERED AN ERROR. C C TAU ABSOLUTE TOLERANCE PARAMETER PROVIDED BY USER C FOR PSEUDORANK DETERMINATION. C C H(*),G(*),IP(*) ARRAYS OF WORKING SPACE USED BY HFTI2. C C OUTPUT.. C C A(*,*) THE CONTENTS OF THE ARRAY A(*,*) WILL BE C MODIFIED BY THE SUBROUTINE. THESE CONTENTS C ARE NOT GENERALLY REQUIRED BY THE USER. C C B(*) ON RETURN THE ARRAY B(*) WILL CONTAIN THE N BY C NB SOLUTION MATRIX X. C C D(*) THE ARRAY OF DIAGONAL ELEMENTS OF THE C TRIANGULAR MATRIX R C C K SET BY THE SUBROUTINE TO INDICATE THE C PSEUDORANK OF A. C C RNORM(*) ON RETURN, RNORM(J) WILL CONTAIN THE EUCLIDEAN C NORM OF THE RESIDUAL VECTOR FOR THE PROBLEM C DEFINED BY THE J-TH COLUMN VECTOR OF THE ARRAY C B(*,*) FOR J = 1,...,NB. C C H(*),G(*) ON RETURN THESE ARRAYS RESPECTIVELY CONTAIN C ELEMENTS OF THE PRE- AND POST-MULTIPLYING C HOUSEHOLDER TRANSFORMATIONS USED TO COMPUTE C THE MINIMUM EUCLIDEAN LENGTH SOLUTION. C C IP(*) ARRAY IN WHICH THE SUBROUTINE RECORDS INDICES C DESCRIBING THE PERMUTATION OF COLUMN VECTORS. C THE CONTENTS OF ARRAYS H(*),G(*) AND IP(*) C ARE NOT GENERALLY REQUIRED BY THE USER. C C IERR ERROR INDICATOR. IF NO INPUT ERRORS ARE C DETECTED THEN IERR IS SET TO 0. OTHERWISE C IERR = 1 IF MDA.LT.M C IERR = 2 IF NB.GT.1 AND MDB.LT.MAX(M,N) C THESE ERRORS ARE FATAL. C----------------------------------------------------------------------- DIMENSION A(MDA,N),B(MDB,*),D(*),RNORM(*),H(N),G(N) INTEGER IP(N) DOUBLE PRECISION SM C--------------------- DATA FACTOR /1.E-3/ C K = 0 LDIAG = MIN0(M,N) IF (LDIAG .LE. 0) GO TO 270 IF (M .GT. MDA) GO TO 300 IF (NB .GT. 1 .AND. MAX0(M,N) .GT. MDB) GO TO 310 C DO 80 J = 1,LDIAG IF (J .EQ. 1) GO TO 20 C C UPDATE SQUARED COLUMN LENGTHS AND FIND LMAX C .. LMAX = J DO 10 L = J,N H(L) = H(L) - A(J-1,L)**2 IF (H(L) .GT. H(LMAX)) LMAX = L 10 CONTINUE Z = HMAX + FACTOR*H(LMAX) IF (Z .GT. HMAX) GO TO 50 C C COMPUTE SQUARED COLUMN LENGTHS AND FIND LMAX C .. 20 LMAX = J DO 40 L = J,N H(L) = 0.0 DO 30 I = J,M 30 H(L) = H(L) + A(I,L)**2 IF (H(L) .GT. H(LMAX)) LMAX = L 40 CONTINUE HMAX = H(LMAX) C .. C LMAX HAS BEEN DETERMINED C C DO COLUMN INTERCHANGES IF NEEDED. C .. 50 IP(J) = LMAX IF (IP(J) .EQ. J) GO TO 70 DO 60 I = 1,M TMP = A(I,J) A(I,J) = A(I,LMAX) 60 A(I,LMAX) = TMP H(LMAX) = H(J) C C COMPUTE THE J-TH TRANSFORMATION AND APPLY IT TO A AND B. C .. 70 CALL H12 (1,J,J+1,M,A(1,J),1,H(J),A(1,J+1),1,MDA,N-J) 80 CALL H12 (2,J,J+1,M,A(1,J),1,H(J),B,1,MDB,NB) C C DETERMINE THE PSEUDORANK, K, USING THE TOLERANCE, TAU. C ALSO STORE THE DIAGONAL ELEMENTS IN THE ARRAY D. C .. DO 90 J = 1,LDIAG IF (ABS(A(J,J)) .LE. TAU) GO TO 100 90 D(J) = A(J,J) K = LDIAG KP1 = K + 1 GO TO 110 C 100 K = J - 1 KP1 = J DO 105 J = KP1,LDIAG 105 D(J) = A(J,J) C C COMPUTE THE NORMS OF THE RESIDUAL VECTORS. C 110 IF (NB .LE. 0) GO TO 140 DO 130 JB = 1,NB TMP = 0.0 IF (KP1 .GT. M) GO TO 130 DO 120 I = KP1,M 120 TMP = TMP + B(I,JB)**2 130 RNORM(JB) = SQRT(TMP) 140 CONTINUE C SPECIAL FOR PSEUDORANK = 0 IF (K .GT. 0) GO TO 160 IF (NB .LE. 0) GO TO 270 DO 151 JB = 1,NB DO 150 I = 1,N 150 B(I,JB) = 0.0 151 CONTINUE GO TO 270 C C IF THE PSEUDORANK IS LESS THAN N COMPUTE HOUSEHOLDER C DECOMPOSITION OF FIRST K ROWS. C .. 160 IF (K .EQ. N) GO TO 180 DO 170 II = 1,K I = KP1 - II 170 CALL H12 (1,I,KP1,N,A(I,1),MDA,G(I),A,MDA,1,I-1) 180 CONTINUE C C IF (NB .LE. 0) GO TO 270 DO 260 JB = 1,NB C C SOLVE THE K BY K TRIANGULAR SYSTEM. C .. DO 210 L = 1,K SM = 0.D0 I = KP1 - L IF (I .EQ. K) GO TO 200 IP1 = I + 1 DO 190 J = IP1,K 190 SM = SM + DBLE(A(I,J))*DBLE(B(J,JB)) 200 SM1 = DBLE(B(I,JB)) - SM 210 B(I,JB)=SM1/A(I,I) C C COMPLETE COMPUTATION OF SOLUTION VECTOR. C .. IF (K .EQ. N) GO TO 240 DO 220 J = KP1,N 220 B(J,JB) = 0.0 DO 230 I = 1,K 230 CALL H12 (2,I,KP1,N,A(I,1),MDA,G(I),B(1,JB),1,MDB,1) C C RE-ORDER THE SOLUTION VECTOR TO COMPENSATE FOR THE C COLUMN INTERCHANGES. C .. 240 DO 250 JJ = 1,LDIAG J = LDIAG + 1 - JJ IF (IP(J) .EQ. J) GO TO 250 L = IP(J) TMP = B(L,JB) B(L,JB) = B(J,JB) B(J,JB) = TMP 250 CONTINUE 260 CONTINUE C .. C THE SOLUTION VECTORS, X, ARE NOW C IN THE FIRST N ROWS OF THE ARRAY B(,). C 270 IERR = 0 RETURN C C ERROR RETURN C 300 IERR = 1 RETURN 310 IERR = 2 RETURN END SUBROUTINE H12 (MODE,LPIVOT,L1,M,U,IUE,UP,C,ICE,ICV,NCV) C----------------------------------------------------------------------- C WRITTEN BY C.L. LAWSON AND R.J. HANSON. MODIFIED BY A.H. MORRIS. C FROM THE BOOK SOLVING LEAST SQUARES PROBLEMS, PRENTICE-HALL, 1974. C C CONSTRUCTION AND/OR APPLICATION OF A SINGLE C HOUSEHOLDER TRANSFORMATION.. Q = I + U*(U**T)/B C C MODE = 1 OR 2 TO SELECT ALGORITHM H1 OR H2 . C LPIVOT IS THE INDEX OF THE PIVOT ELEMENT. C L1,M IF L1 .LE. M THE TRANSFORMATION WILL BE CONSTRUCTED TO C ZERO ELEMENTS INDEXED FROM L1 THROUGH M. IF L1 GT. M C THE SUBROUTINE DOES AN IDENTITY TRANSFORMATION. C U(),IUE,UP ON ENTRY TO H1 U() CONTAINS THE PIVOT VECTOR. C IUE IS THE STORAGE INCREMENT BETWEEN ELEMENTS. C ON EXIT FROM H1 U() AND UP C CONTAIN QUANTITIES DEFINING THE VECTOR U OF THE C HOUSEHOLDER TRANSFORMATION. ON ENTRY TO H2 U() C AND UP SHOULD CONTAIN QUANTITIES PREVIOUSLY COMPUTED C BY H1. THESE WILL NOT BE MODIFIED BY H2. C C() ON ENTRY TO H1 OR H2 C() CONTAINS A MATRIX WHICH WILL BE C REGARDED AS A SET OF VECTORS TO WHICH THE HOUSEHOLDER C TRANSFORMATION IS TO BE APPLIED. ON EXIT C() CONTAINS THE C SET OF TRANSFORMED VECTORS. C ICE STORAGE INCREMENT BETWEEN ELEMENTS OF VECTORS IN C(). C ICV STORAGE INCREMENT BETWEEN VECTORS IN C(). C NCV NUMBER OF VECTORS IN C() TO BE TRANSFORMED. IF NCV .LE. 0 C NO OPERATIONS WILL BE DONE ON C(). C----------------------------------------------------------------------- DIMENSION U(IUE,M), C(*) DOUBLE PRECISION SM,B C IF (0 .GE. LPIVOT .OR. LPIVOT .GE. L1 .OR. L1 .GT. M) RETURN CL = ABS(U(1,LPIVOT)) IF (MODE .EQ. 2) GO TO 60 C C ****** CONSTRUCT THE TRANSFORMATION. ****** C DO 10 J = L1,M 10 CL = AMAX1(ABS(U(1,J)),CL) IF (CL .LE. 0.0) GO TO 130 D = U(1,LPIVOT)/CL SM = D*D DO 20 J = L1,M D = U(1,J)/CL 20 SM = SM + DBLE(D*D) C SM1 = SM CL = CL*SQRT(SM1) IF (U(1,LPIVOT) .GT. 0.0) CL = -CL UP = U(1,LPIVOT) - CL U(1,LPIVOT) = CL GO TO 70 C C ****** APPLY THE TRANSFORMATION I+U*(U**T)/B TO C. ****** C 60 IF (CL) 130,130,70 70 IF (NCV .LE. 0) RETURN B = DBLE(UP)*DBLE(U(1,LPIVOT)) C C B MUST BE NONPOSITIVE HERE. IF B = 0., RETURN. C IF (B .GE. 0.D0) GO TO 130 B = 1.D0/B I2 = 1 - ICV + ICE*(LPIVOT - 1) INCR = ICE*(L1 - LPIVOT) DO 120 J = 1,NCV I2 = I2 + ICV I3 = I2 + INCR I4 = I3 SM = DBLE(C(I2))*DBLE(UP) DO 90 I = L1,M SM = SM + DBLE(C(I3))*DBLE(U(1,I)) 90 I3 = I3 + ICE IF (SM .EQ. 0.D0) GO TO 120 SM = SM*B C(I2) = C(I2) + SM*DBLE(UP) DO 110 I = L1,M C(I4) = C(I4) + SM*DBLE(U(1,I)) 110 I4 = I4 + ICE 120 CONTINUE 130 RETURN END SUBROUTINE DHFTI (A,MDA,M,N,B,MDB,NB,TAU,K,RNORM,H,G,IP) C----------------------------------------------------------------------- C DOUBLE PRECISION A(MDA,N),(B(MDB,NB) OR B(M)) C DOUBLE PRECISION TAU,RNORM(NB),H(N),G(N) C INTEGER IP(N) C C WRITTEN BY C.L. LAWSON AND R.J. HANSON. C FROM THE BOOK SOLVING LEAST SQUARES PROBLEMS, PRENTICE-HALL, 1974. C FOR ALGORITHMIC DETAILS SEE ALGORITHM HFTI IN CHAPTER 14. C C ABSTRACT C C THIS SUBROUTINE SOLVES A LINEAR LEAST SQUARES PROBLEM OR A SET OF C LINEAR LEAST SQUARES PROBLEMS HAVING THE SAME MATRIX BUT DIFFERENT C RIGHT-SIDE VECTORS. THE PROBLEM DATA CONSISTS OF AN M BY N MATRIX C A, AN M BY NB MATRIX B, AND AN ABSOLUTE TOLERANCE PARAMETER TAU C WHOSE USAGE IS DESCRIBED BELOW. THE NB COLUMN VECTORS OF B C REPRESENT RIGHT-SIDE VECTORS FOR NB DISTINCT LINEAR LEAST SQUARES C PROBLEMS. C C THIS SET OF PROBLEMS CAN ALSO BE WRITTEN AS THE MATRIX LEAST C SQUARES PROBLEM C C AX = B, C C WHERE X IS THE N BY NB SOLUTION MATRIX. C C NOTE THAT IF B IS THE M BY M IDENTITY MATRIX, THEN X WILL BE THE C PSEUDO-INVERSE OF A. C C THIS SUBROUTINE FIRST TRANSFORMS THE AUGMENTED MATRIX (A B) TO A C MATRIX (R C) USING PREMULTIPLYING HOUSEHOLDER TRANSFORMATIONS WITH C COLUMN INTERCHANGES. ALL SUBDIAGONAL ELEMENTS IN THE MATRIX R ARE C ZERO AND ITS DIAGONAL ELEMENTS SATISFY C C DABS(R(I,I)).GE.DABS(R(I+1,I+1)), C C I = 1,...,L-1, WHERE C C L = MIN(M,N). C C THE SUBROUTINE SETS K TO BE THE NUMBER OF DIAGONAL ELEMENTS C OF R THAT EXCEED TAU IN MAGNITUDE. THEN THE SOLUTION OF MINIMUM C EUCLIDEAN LENGTH IS COMPUTED USING THE FIRST K ROWS OF (R C). C C TO BE SPECIFIC WE SUGGEST THAT THE USER CONSIDER AN EASILY C COMPUTABLE MATRIX NORM, SUCH AS, THE MAXIMUM OF ALL COLUMN SUMS OF C MAGNITUDES. C C NOW IF THE RELATIVE UNCERTAINTY OF B IS EPS, (NORM OF UNCERTAINTY/ C NORM OF B), IT IS SUGGESTED THAT TAU BE SET APPROXIMATELY EQUAL TO C EPS*(NORM OF A). C C THE ENTIRE SET OF PARAMETERS FOR DHFTI ARE C C INPUT.. C C A(*,*),MDA,M,N THE ARRAY A(*,*) INITIALLY CONTAINS THE M BY N C MATRIX A OF THE LEAST SQUARES PROBLEM AX = B. C THE FIRST DIMENSIONING PARAMETER OF THE ARRAY C A(*,*) IS MDA, WHICH MUST SATISFY MDA.GE.M C EITHER M.GE.N OR M.LT.N IS PERMITTED. THERE C IS NO RESTRICTION ON THE RANK OF A. THE C CONDITION MDA.LT.M IS CONSIDERED AN ERROR. C C B(*),MDB,NB IF NB = 0 THE SUBROUTINE WILL PERFORM THE C ORTHOGONAL DECOMPOSITION BUT WILL MAKE NO C REFERENCES TO THE ARRAY B(*). IF NB.GT.0 C THE ARRAY B(*) MUST INITIALLY CONTAIN THE M BY C NB MATRIX B OF THE LEAST SQUARES PROBLEM AX = C B. IF NB.GE.2 THE ARRAY B(*) MUST BE DOUBLY C SUBSCRIPTED WITH FIRST DIMENSIONING PARAMETER C MDB.GE.MAX(M,N). IF NB = 1 THE ARRAY B(*) MAY C BE EITHER DOUBLY OR SINGLY SUBSCRIPTED. IN C THE LATTER CASE THE VALUE OF MDB IS ARBITRARY C BUT IT SHOULD BE SET TO SOME VALID INTEGER C VALUE SUCH AS MDB = M. C C THE CONDITION OF NB.GT.1.AND.MDB.LT. MAX(M,N) C IS CONSIDERED AN ERROR. C C TAU ABSOLUTE TOLERANCE PARAMETER PROVIDED BY USER C FOR PSEUDORANK DETERMINATION. C C H(*),G(*),IP(*) ARRAYS OF WORKING SPACE USED BY DHFTI. C C OUTPUT.. C C A(*,*) THE CONTENTS OF THE ARRAY A(*,*) WILL BE C MODIFIED BY THE SUBROUTINE. THESE CONTENTS C ARE NOT GENERALLY REQUIRED BY THE USER. C C B(*) ON RETURN THE ARRAY B(*) WILL CONTAIN THE N BY C NB SOLUTION MATRIX X. C C K SET BY THE SUBROUTINE TO INDICATE THE C PSEUDORANK OF A. C C RNORM(*) ON RETURN, RNORM(J) WILL CONTAIN THE EUCLIDEAN C NORM OF THE RESIDUAL VECTOR FOR THE PROBLEM C DEFINED BY THE J-TH COLUMN VECTOR OF THE ARRAY C B(*,*) FOR J = 1,...,NB. C C H(*),G(*) ON RETURN THESE ARRAYS RESPECTIVELY CONTAIN C ELEMENTS OF THE PRE- AND POST-MULTIPLYING C HOUSEHOLDER TRANSFORMATIONS USED TO COMPUTE C THE MINIMUM EUCLIDEAN LENGTH SOLUTION. C C IP(*) ARRAY IN WHICH THE SUBROUTINE RECORDS INDICES C DESCRIBING THE PERMUTATION OF COLUMN VECTORS. C THE CONTENTS OF ARRAYS H(*),G(*) AND IP(*) C ARE NOT GENERALLY REQUIRED BY THE USER. C----------------------------------------------------------------------- DOUBLE PRECISION A(MDA,N),B(MDB,*),TAU,RNORM(*),H(N),G(N) INTEGER IP(N) DOUBLE PRECISION FACTOR,HMAX,SM,SM1,TMP,Z C--------------------- DATA FACTOR /1.D-3/ C K = 0 LDIAG = MIN0(M,N) IF (LDIAG .LE. 0) GO TO 270 DO 80 J = 1,LDIAG IF (J .EQ. 1) GO TO 20 C C UPDATE SQUARED COLUMN LENGTHS AND FIND LMAX C .. LMAX = J DO 10 L = J,N H(L) = H(L) - A(J-1,L)**2 IF (H(L) .GT. H(LMAX)) LMAX = L 10 CONTINUE Z = HMAX + FACTOR*H(LMAX) IF (Z .GT. HMAX) GO TO 50 C C COMPUTE SQUARED COLUMN LENGTHS AND FIND LMAX C .. 20 LMAX=J DO 40 L = J,N H(L) = 0.D0 DO 30 I = J,M 30 H(L) = H(L) + A(I,L)**2 IF (H(L) .GT. H(LMAX)) LMAX = L 40 CONTINUE HMAX = H(LMAX) C .. C LMAX HAS BEEN DETERMINED C C DO COLUMN INTERCHANGES IF NEEDED. C .. 50 IP(J) = LMAX IF (IP(J) .EQ. J) GO TO 70 DO 60 I = 1,M TMP = A(I,J) A(I,J) = A(I,LMAX) 60 A(I,LMAX) = TMP H(LMAX) = H(J) C C COMPUTE THE J-TH TRANSFORMATION AND APPLY IT TO A AND B. C .. 70 CALL DH12 (1,J,J+1,M,A(1,J),1,H(J),A(1,J+1),1,MDA,N-J) 80 CALL DH12 (2,J,J+1,M,A(1,J),1,H(J),B,1,MDB,NB) C C DETERMINE THE PSEUDORANK, K, USING THE TOLERANCE, TAU. C .. DO 90 J = 1,LDIAG IF (DABS(A(J,J)) .LE. TAU) GO TO 100 90 CONTINUE K = LDIAG GO TO 110 100 K = J - 1 110 KP1 = K + 1 C C COMPUTE THE NORMS OF THE RESIDUAL VECTORS. C IF (NB .LE. 0) GO TO 140 DO 130 JB = 1,NB TMP = 0.D0 IF (KP1 .GT. M) GO TO 130 DO 120 I = KP1,M 120 TMP = TMP + B(I,JB)**2 130 RNORM(JB) = DSQRT(TMP) 140 CONTINUE C SPECIAL FOR PSEUDORANK = 0 IF (K .GT. 0) GO TO 160 IF (NB .LE. 0) GO TO 270 DO 151 JB = 1,NB DO 150 I = 1,N 150 B(I,JB) = 0.D0 151 CONTINUE GO TO 270 C C IF THE PSEUDORANK IS LESS THAN N COMPUTE HOUSEHOLDER C DECOMPOSITION OF FIRST K ROWS. C .. 160 IF (K .EQ. N) GO TO 180 DO 170 II = 1,K I = KP1 - II 170 CALL DH12 (1,I,KP1,N,A(I,1),MDA,G(I),A,MDA,1,I-1) 180 CONTINUE C C IF (NB .LE. 0) GO TO 270 DO 260 JB = 1,NB C C SOLVE THE K BY K TRIANGULAR SYSTEM. C .. DO 210 L = 1,K SM = 0.D0 I = KP1 - L IF (I .EQ. K) GO TO 200 IP1 = I + 1 DO 190 J = IP1,K 190 SM = SM + A(I,J)*B(J,JB) 200 SM1 = B(I,JB) - SM 210 B(I,JB) = SM1/A(I,I) C C COMPLETE COMPUTATION OF SOLUTION VECTOR. C .. IF (K .EQ. N) GO TO 240 DO 220 J = KP1,N 220 B(J,JB) = 0.D0 DO 230 I = 1,K 230 CALL DH12 (2,I,KP1,N,A(I,1),MDA,G(I),B(1,JB),1,MDB,1) C C RE-ORDER THE SOLUTION VECTOR TO COMPENSATE FOR THE C COLUMN INTERCHANGES. C .. 240 DO 250 JJ = 1,LDIAG J = LDIAG + 1 - JJ IF (IP(J) .EQ. J) GO TO 250 L = IP(J) TMP = B(L,JB) B(L,JB) = B(J,JB) B(J,JB) = TMP 250 CONTINUE 260 CONTINUE C .. C THE SOLUTION VECTORS, X, ARE NOW C IN THE FIRST N ROWS OF THE ARRAY B(,). C 270 RETURN END SUBROUTINE DHFTI2(A,MDA,M,N,B,MDB,NB,D,TAU,K,RNORM,H,G,IP,IERR) C----------------------------------------------------------------------- C DOUBLE PRECISION A(MDA,N),(B(MDB,NB) OR B(M)) C DOUBLE PRECISION D(L) WHERE L = MIN(M,N) C DOUBLE PRECISION TAU,RNORM(NB),H(N),G(N) C INTEGER IP(N) C C WRITTEN BY C.L. LAWSON AND R.J. HANSON. MODIFIED BY A.H. MORRIS. C FROM THE BOOK SOLVING LEAST SQUARES PROBLEMS, PRENTICE-HALL, 1974. C FOR ALGORITHMIC DETAILS SEE ALGORITHM HFTI IN CHAPTER 14. C C ABSTRACT C C THIS SUBROUTINE SOLVES A LINEAR LEAST SQUARES PROBLEM OR A SET OF C LINEAR LEAST SQUARES PROBLEMS HAVING THE SAME MATRIX BUT DIFFERENT C RIGHT-SIDE VECTORS. THE PROBLEM DATA CONSISTS OF AN M BY N MATRIX C A, AN M BY NB MATRIX B, AND AN ABSOLUTE TOLERANCE PARAMETER TAU C WHOSE USAGE IS DESCRIBED BELOW. THE NB COLUMN VECTORS OF B C REPRESENT RIGHT-SIDE VECTORS FOR NB DISTINCT LINEAR LEAST SQUARES C PROBLEMS. C C THIS SET OF PROBLEMS CAN ALSO BE WRITTEN AS THE MATRIX LEAST C SQUARES PROBLEM C C AX = B, C C WHERE X IS THE N BY NB SOLUTION MATRIX. C C NOTE THAT IF B IS THE M BY M IDENTITY MATRIX, THEN X WILL BE THE C PSEUDO-INVERSE OF A. C C THIS SUBROUTINE FIRST TRANSFORMS THE AUGMENTED MATRIX (A B) TO A C MATRIX (R C) USING PREMULTIPLYING HOUSEHOLDER TRANSFORMATIONS WITH C COLUMN INTERCHANGES. ALL SUBDIAGONAL ELEMENTS IN THE MATRIX R ARE C ZERO AND ITS DIAGONAL ELEMENTS SATISFY C C DABS(R(I,I)).GE.DABS(R(I+1,I+1)), C C I = 1,...,L-1, WHERE C C L = MIN(M,N). C C THE ARRAY D WILL CONTAIN THE DIAGONAL ELEMENTS R(1,1),...,R(L,L). C THE SUBROUTINE SETS K TO BE THE NUMBER OF DIAGONAL ELEMENTS THAT C EXCEED TAU IN MAGNITUDE. THEN THE SOLUTION OF MINIMUM EUCLIDEAN C LENGTH IS COMPUTED USING THE FIRST K ROWS OF (R C). C C TO BE SPECIFIC WE SUGGEST THAT THE USER CONSIDER AN EASILY C COMPUTABLE MATRIX NORM, SUCH AS, THE MAXIMUM OF ALL COLUMN SUMS OF C MAGNITUDES. C C NOW IF THE RELATIVE UNCERTAINTY OF B IS EPS, (NORM OF UNCERTAINTY/ C NORM OF B), IT IS SUGGESTED THAT TAU BE SET APPROXIMATELY EQUAL TO C EPS*(NORM OF A). C C THE ENTIRE SET OF PARAMETERS FOR DHFTI2 ARE C C INPUT.. C C A(*,*),MDA,M,N THE ARRAY A(*,*) INITIALLY CONTAINS THE M BY N C MATRIX A OF THE LEAST SQUARES PROBLEM AX = B. C THE FIRST DIMENSIONING PARAMETER OF THE ARRAY C A(*,*) IS MDA, WHICH MUST SATISFY MDA.GE.M C EITHER M.GE.N OR M.LT.N IS PERMITTED. THERE C IS NO RESTRICTION ON THE RANK OF A. THE C CONDITION MDA.LT.M IS CONSIDERED AN ERROR. C C B(*),MDB,NB IF NB = 0 THE SUBROUTINE WILL PERFORM THE C ORTHOGONAL DECOMPOSITION BUT WILL MAKE NO C REFERENCES TO THE ARRAY B(*). IF NB.GT.0 C THE ARRAY B(*) MUST INITIALLY CONTAIN THE M BY C NB MATRIX B OF THE LEAST SQUARES PROBLEM AX = C B. IF NB.GE.2 THE ARRAY B(*) MUST BE DOUBLY C SUBSCRIPTED WITH FIRST DIMENSIONING PARAMETER C MDB.GE.MAX(M,N). IF NB = 1 THE ARRAY B(*) MAY C BE EITHER DOUBLY OR SINGLY SUBSCRIPTED. IN C THE LATTER CASE THE VALUE OF MDB IS ARBITRARY C BUT IT SHOULD BE SET TO SOME VALID INTEGER C VALUE SUCH AS MDB = M. C C THE CONDITION OF NB.GT.1.AND.MDB.LT. MAX(M,N) C IS CONSIDERED AN ERROR. C C TAU ABSOLUTE TOLERANCE PARAMETER PROVIDED BY USER C FOR PSEUDORANK DETERMINATION. C C H(*),G(*),IP(*) ARRAYS OF WORKING SPACE USED BY DHFTI2. C C OUTPUT.. C C A(*,*) THE CONTENTS OF THE ARRAY A(*,*) WILL BE C MODIFIED BY THE SUBROUTINE. THESE CONTENTS C ARE NOT GENERALLY REQUIRED BY THE USER. C C B(*) ON RETURN THE ARRAY B(*) WILL CONTAIN THE N BY C NB SOLUTION MATRIX X. C C D(*) THE ARRAY OF DIAGONAL ELEMENTS OF THE C TRIANGULAR MATRIX R C C K SET BY THE SUBROUTINE TO INDICATE THE C PSEUDORANK OF A. C C RNORM(*) ON RETURN, RNORM(J) WILL CONTAIN THE EUCLIDEAN C NORM OF THE RESIDUAL VECTOR FOR THE PROBLEM C DEFINED BY THE J-TH COLUMN VECTOR OF THE ARRAY C B(*,*) FOR J = 1,...,NB. C C H(*),G(*) ON RETURN THESE ARRAYS RESPECTIVELY CONTAIN C ELEMENTS OF THE PRE- AND POST-MULTIPLYING C HOUSEHOLDER TRANSFORMATIONS USED TO COMPUTE C THE MINIMUM EUCLIDEAN LENGTH SOLUTION. C C IP(*) ARRAY IN WHICH THE SUBROUTINE RECORDS INDICES C DESCRIBING THE PERMUTATION OF COLUMN VECTORS. C THE CONTENTS OF ARRAYS H(*),G(*) AND IP(*) C ARE NOT GENERALLY REQUIRED BY THE USER. C C IERR ERROR INDICATOR. IF NO INPUT ERRORS ARE C DETECTED THEN IERR IS SET TO 0. OTHERWISE C IERR = 1 IF MDA.LT.M C IERR = 2 IF NB.GT.1 AND MDB.LT.MAX(M,N) C THESE ERRORS ARE FATAL. C----------------------------------------------------------------------- DOUBLE PRECISION A(MDA,N),B(MDB,*),D(*),TAU,RNORM(*),H(N),G(N) INTEGER IP(N) DOUBLE PRECISION FACTOR,HMAX,SM,SM1,TMP,Z C--------------------- DATA FACTOR /1.D-3/ C K = 0 LDIAG = MIN0(M,N) IF (LDIAG .LE. 0) GO TO 270 IF (M .GT. MDA) GO TO 300 IF (NB .GT. 1 .AND. MAX0(M,N) .GT. MDB) GO TO 310 C DO 80 J = 1,LDIAG IF (J .EQ. 1) GO TO 20 C C UPDATE SQUARED COLUMN LENGTHS AND FIND LMAX C .. LMAX = J DO 10 L = J,N H(L) = H(L) - A(J-1,L)**2 IF (H(L) .GT. H(LMAX)) LMAX = L 10 CONTINUE Z = HMAX + FACTOR*H(LMAX) IF (Z .GT. HMAX) GO TO 50 C C COMPUTE SQUARED COLUMN LENGTHS AND FIND LMAX C .. 20 LMAX = J DO 40 L = J,N H(L) = 0.D0 DO 30 I = J,M 30 H(L) = H(L) + A(I,L)**2 IF (H(L) .GT. H(LMAX)) LMAX = L 40 CONTINUE HMAX = H(LMAX) C .. C LMAX HAS BEEN DETERMINED C C DO COLUMN INTERCHANGES IF NEEDED. C .. 50 IP(J) = LMAX IF (IP(J) .EQ. J) GO TO 70 DO 60 I = 1,M TMP = A(I,J) A(I,J) = A(I,LMAX) 60 A(I,LMAX) = TMP H(LMAX) = H(J) C C COMPUTE THE J-TH TRANSFORMATION AND APPLY IT TO A AND B. C .. 70 CALL DH12 (1,J,J+1,M,A(1,J),1,H(J),A(1,J+1),1,MDA,N-J) 80 CALL DH12 (2,J,J+1,M,A(1,J),1,H(J),B,1,MDB,NB) C C DETERMINE THE PSEUDORANK, K, USING THE TOLERANCE, TAU. C ALSO STORE THE DIAGONAL ELEMENTS IN THE ARRAY D. C .. DO 90 J = 1,LDIAG IF (DABS(A(J,J)) .LE. TAU) GO TO 100 90 D(J) = A(J,J) K = LDIAG KP1 = K + 1 GO TO 110 C 100 K = J - 1 KP1 = J DO 105 J = KP1,LDIAG 105 D(J) = A(J,J) C C COMPUTE THE NORMS OF THE RESIDUAL VECTORS. C 110 IF (NB .LE. 0) GO TO 140 DO 130 JB = 1,NB TMP = 0.D0 IF (KP1 .GT. M) GO TO 130 DO 120 I = KP1,M 120 TMP = TMP + B(I,JB)**2 130 RNORM(JB) = DSQRT(TMP) 140 CONTINUE C SPECIAL FOR PSEUDORANK = 0 IF (K .GT. 0) GO TO 160 IF (NB .LE. 0) GO TO 270 DO 151 JB = 1,NB DO 150 I = 1,N 150 B(I,JB) = 0.D0 151 CONTINUE GO TO 270 C C IF THE PSEUDORANK IS LESS THAN N COMPUTE HOUSEHOLDER C DECOMPOSITION OF FIRST K ROWS. C .. 160 IF (K .EQ. N) GO TO 180 DO 170 II = 1,K I = KP1 - II 170 CALL DH12 (1,I,KP1,N,A(I,1),MDA,G(I),A,MDA,1,I-1) 180 CONTINUE C C IF (NB .LE. 0) GO TO 270 DO 260 JB = 1,NB C C SOLVE THE K BY K TRIANGULAR SYSTEM. C .. DO 210 L = 1,K SM = 0.D0 I = KP1 - L IF (I .EQ. K) GO TO 200 IP1 = I + 1 DO 190 J = IP1,K 190 SM = SM + A(I,J)*B(J,JB) 200 SM1 = B(I,JB) - SM 210 B(I,JB)=SM1/A(I,I) C C COMPLETE COMPUTATION OF SOLUTION VECTOR. C .. IF (K .EQ. N) GO TO 240 DO 220 J = KP1,N 220 B(J,JB) = 0.D0 DO 230 I = 1,K 230 CALL DH12 (2,I,KP1,N,A(I,1),MDA,G(I),B(1,JB),1,MDB,1) C C RE-ORDER THE SOLUTION VECTOR TO COMPENSATE FOR THE C COLUMN INTERCHANGES. C .. 240 DO 250 JJ = 1,LDIAG J = LDIAG + 1 - JJ IF (IP(J) .EQ. J) GO TO 250 L = IP(J) TMP = B(L,JB) B(L,JB) = B(J,JB) B(J,JB) = TMP 250 CONTINUE 260 CONTINUE C .. C THE SOLUTION VECTORS, X, ARE NOW C IN THE FIRST N ROWS OF THE ARRAY B(,). C 270 IERR = 0 RETURN C C ERROR RETURN C 300 IERR = 1 RETURN 310 IERR = 2 RETURN END SUBROUTINE DH12 (MODE,LPIVOT,L1,M,U,IUE,UP,C,ICE,ICV,NCV) C----------------------------------------------------------------------- C WRITTEN BY C.L. LAWSON AND R.J. HANSON. MODIFIED BY A.H. MORRIS. C FROM THE BOOK SOLVING LEAST SQUARES PROBLEMS, PRENTICE-HALL, 1974. C C CONSTRUCTION AND/OR APPLICATION OF A SINGLE C HOUSEHOLDER TRANSFORMATION.. Q = I + U*(U**T)/B C C MODE = 1 OR 2 TO SELECT ALGORITHM H1 OR H2 . C LPIVOT IS THE INDEX OF THE PIVOT ELEMENT. C L1,M IF L1 .LE. M THE TRANSFORMATION WILL BE CONSTRUCTED TO C ZERO ELEMENTS INDEXED FROM L1 THROUGH M. IF L1 GT. M C THE SUBROUTINE DOES AN IDENTITY TRANSFORMATION. C U(),IUE,UP ON ENTRY TO H1 U() CONTAINS THE PIVOT VECTOR. C IUE IS THE STORAGE INCREMENT BETWEEN ELEMENTS. C ON EXIT FROM H1 U() AND UP C CONTAIN QUANTITIES DEFINING THE VECTOR U OF THE C HOUSEHOLDER TRANSFORMATION. ON ENTRY TO H2 U() C AND UP SHOULD CONTAIN QUANTITIES PREVIOUSLY COMPUTED C BY H1. THESE WILL NOT BE MODIFIED BY H2. C C() ON ENTRY TO H1 OR H2 C() CONTAINS A MATRIX WHICH WILL BE C REGARDED AS A SET OF VECTORS TO WHICH THE HOUSEHOLDER C TRANSFORMATION IS TO BE APPLIED. ON EXIT C() CONTAINS THE C SET OF TRANSFORMED VECTORS. C ICE STORAGE INCREMENT BETWEEN ELEMENTS OF VECTORS IN C(). C ICV STORAGE INCREMENT BETWEEN VECTORS IN C(). C NCV NUMBER OF VECTORS IN C() TO BE TRANSFORMED. IF NCV .LE. 0 C NO OPERATIONS WILL BE DONE ON C(). C----------------------------------------------------------------------- DOUBLE PRECISION U(IUE,M),UP,C(*) DOUBLE PRECISION B,CL,D,SM C IF (0 .GE. LPIVOT .OR. LPIVOT .GE. L1 .OR. L1 .GT. M) RETURN CL = DABS(U(1,LPIVOT)) IF (MODE .EQ. 2) GO TO 60 C C ****** CONSTRUCT THE TRANSFORMATION. ****** C DO 10 J = L1,M 10 CL = DMAX1(DABS(U(1,J)),CL) IF (CL .LE. 0.D0) GO TO 130 D = U(1,LPIVOT)/CL SM = D*D DO 20 J = L1,M D = U(1,J)/CL 20 SM = SM + D*D C CL = CL*DSQRT(SM) IF (U(1,LPIVOT) .GT. 0.D0) CL = -CL UP = U(1,LPIVOT) - CL U(1,LPIVOT) = CL GO TO 70 C C ****** APPLY THE TRANSFORMATION I+U*(U**T)/B TO C. ****** C 60 IF (CL) 130,130,70 70 IF (NCV .LE. 0) RETURN B = UP*U(1,LPIVOT) C C B MUST BE NONPOSITIVE HERE. IF B = 0., RETURN. C IF (B .GE. 0.D0) GO TO 130 B = 1.D0/B I2 = 1 - ICV + ICE*(LPIVOT - 1) INCR = ICE*(L1 - LPIVOT) DO 120 J = 1,NCV I2 = I2 + ICV I3 = I2 + INCR I4 = I3 SM = C(I2)*UP DO 90 I = L1,M SM = SM + C(I3)*U(1,I) 90 I3 = I3 + ICE IF (SM .EQ. 0.D0) GO TO 120 SM = SM*B C(I2) = C(I2) + SM*UP DO 110 I = L1,M C(I4) = C(I4) + SM*U(1,I) 110 I4 = I4 + ICE 120 CONTINUE 130 RETURN END SUBROUTINE LSEI(W, MDW, ME, MA, MG, N, PRGOPT, X, RNORME, RNORML, * MODE, WS, IP) C C DIMENSION W(MDW,N+1),PRGOPT(*),X(N), C WS(2*(ME+N)+K+(MG+2)*(N+7)),IP(MG+2*N+2) C ABOVE, K=MAX(MA+MG,N). C C WRITTEN BY R. J. HANSON AND K. H. HASKELL. FOR FURTHER MATH. C AND ALGORITHMIC DETAILS SEE SANDIA LABORATORIES TECH. REPTS. C SAND77-0552, (1978), AND SAND78-1290, (1979), AND MATH. C PROGRAMMING (21), 1981, PP. 98-118. MODIFIED BY A.H. MORRIS. C C ABSTRACT C C THIS SUBPROGRAM SOLVES A LINEARLY CONSTRAINED LEAST SQUARES C PROBLEM WITH BOTH EQUALITY AND INEQUALITY CONSTRAINTS, AND, IF THE C USER REQUESTS, OBTAINS A COVARIANCE MATRIX OF THE SOLUTION C PARAMETERS. C C SUPPOSE THERE ARE GIVEN MATRICES E, A AND G OF RESPECTIVE C DIMENSIONS ME BY N, MA BY N AND MG BY N, AND VECTORS F, B AND H OF C RESPECTIVE LENGTHS ME, MA AND MG. THIS SUBROUTINE SOLVES THE C LINEARLY CONSTRAINED LEAST SQUARES PROBLEM C C EX = F, (E ME BY N) (EQUATIONS TO BE EXACTLY C SATISFIED) C AX = B, (A MA BY N) (EQUATIONS TO BE C APPROXIMATELY SATISFIED, C LEAST SQUARES SENSE) C GX.GE.H,(G MG BY N) (INEQUALITY CONSTRAINTS) C C THE INEQUALITIES GX.GE.H MEAN THAT EVERY COMPONENT OF THE PRODUCT C GX MUST BE .GE. THE CORRESPONDING COMPONENT OF H. C C IN CASE THE EQUALITY CONSTRAINTS CANNOT BE SATISFIED, A C GENERALIZED INVERSE SOLUTION RESIDUAL VECTOR LENGTH IS OBTAINED C FOR F-EX. THIS IS THE MINIMAL LENGTH POSSIBLE FOR F-EX. C C C ANY VALUES ME.GE.0, MA.GE.0, OR MG.GE.0 ARE PERMITTED. THE C RANK OF THE MATRIX E IS ESTIMATED DURING THE COMPUTATION. WE CALL C THIS VALUE KRANKE. IT IS AN OUTPUT PARAMETER IN IP(1) DEFINED C BELOW. USING A GENERALIZED INVERSE SOLUTION OF EX=F, A REDUCED C LEAST SQUARES PROBLEM WITH INEQUALITY CONSTRAINTS IS OBTAINED. C THE TOLERANCES USED IN THESE TESTS FOR DETERMINING THE RANK C OF E AND THE RANK OF THE REDUCED LEAST SQUARES PROBLEM ARE C GIVEN IN SANDIA TECH. REPT. SAND78-1290. THEY CAN BE C MODIFIED BY THE USER IF NEW VALUES ARE PROVIDED IN C THE OPTION LIST OF THE ARRAY PRGOPT(*). C C THE USER MUST DIMENSION ALL ARRAYS APPEARING IN THE CALL LIST.. C W(MDW,N+1),PRGOPT(*),X(N),WS(2*(ME+N)+K+(MG+2)*(N+7)),IP(MG+2*N+2) C WHERE K=MAX(MA+MG,N). THIS ALLOWS FOR A SOLUTION OF A RANGE OF C PROBLEMS IN THE GIVEN WORKING SPACE. THE DIMENSION OF WS(*) C GIVEN IS A NECESSARY OVERESTIMATE. ONCE A PARTICULAR PROBLEM C HAS BEEN RUN, THE OUTPUT PARAMETER IP(3) GIVES THE ACTUAL C DIMENSION REQUIRED FOR THAT PROBLEM. C C THE PARAMETERS FOR LSEI( ) ARE C C INPUT.. C C W(*,*),MDW, THE ARRAY W(*,*) IS DOUBLY SUBSCRIPTED WITH C ME,MA,MG,N FIRST DIMENSIONING PARAMETER EQUAL TO MDW. C FOR THIS DISCUSSION LET US CALL M = ME+MA+MG. THEN C MDW MUST SATISFY MDW.GE.M. THE CONDITION C MDW.LT.M IS AN ERROR. C C THE ARRAY W(*,*) CONTAINS THE MATRICES AND VECTORS C C (E F) C (A B) C (G H) C C IN ROWS AND COLUMNS 1,...,M AND 1,...,N+1 C RESPECTIVELY. C C THE INTEGERS ME, MA, AND MG ARE THE C RESPECTIVE MATRIX ROW DIMENSIONS C OF E, A AND G. EACH MATRIX HAS N COLUMNS. C C PRGOPT(*) THIS REAL-VALUED ARRAY IS THE OPTION VECTOR. C IF THE USER IS SATISFIED WITH THE NOMINAL C SUBPROGRAM FEATURES SET C C PRGOPT(1)=1 (OR PRGOPT(1)=1.0) C C OTHERWISE PRGOPT(*) IS A LINKED LIST CONSISTING OF C GROUPS OF DATA OF THE FOLLOWING FORM C C LINK C KEY C DATA SET C C THE PARAMETERS LINK AND KEY ARE EACH ONE WORD. C THE DATA SET CAN BE COMPRISED OF SEVERAL WORDS. C THE NUMBER OF ITEMS DEPENDS ON THE VALUE OF KEY. C THE VALUE OF LINK POINTS TO THE FIRST C ENTRY OF THE NEXT GROUP OF DATA WITHIN C PRGOPT(*). THE EXCEPTION IS WHEN THERE ARE C NO MORE OPTIONS TO CHANGE. IN THAT C CASE LINK=1 AND THE VALUES KEY AND DATA SET C ARE NOT REFERENCED. THE GENERAL LAYOUT OF C PRGOPT(*) IS AS FOLLOWS. C C ...PRGOPT(1)=LINK1 (LINK TO FIRST ENTRY OF NEXT GROUP) C . PRGOPT(2)=KEY1 (KEY TO THE OPTION CHANGE) C . PRGOPT(3)=DATA VALUE (DATA VALUE FOR THIS CHANGE) C . . C . . C . . C ...PRGOPT(LINK1)=LINK2 (LINK TO THE FIRST ENTRY OF C . NEXT GROUP) C . PRGOPT(LINK1+1)=KEY2 (KEY TO THE OPTION CHANGE) C . PRGOPT(LINK1+2)=DATA VALUE C ... . C . . C . . C ...PRGOPT(LINK)=1 (NO MORE OPTIONS TO CHANGE) C C VALUES OF LINK THAT ARE NONPOSITIVE ARE ERRORS. C A VALUE OF LINK.GT.NLINK=100000 IS ALSO AN ERROR. C THIS HELPS PREVENT USING INVALID BUT POSITIVE C VALUES OF LINK THAT WILL PROBABLY EXTEND C BEYOND THE PROGRAM LIMITS OF PRGOPT(*). C UNRECOGNIZED VALUES OF KEY ARE IGNORED. THE C ORDER OF THE OPTIONS IS ARBITRARY AND ANY NUMBER C OF OPTIONS CAN BE CHANGED WITH THE FOLLOWING C RESTRICTION. TO PREVENT CYCLING IN THE C PROCESSING OF THE OPTION ARRAY A COUNT OF THE C NUMBER OF OPTIONS CHANGED IS MAINTAINED. C WHENEVER THIS COUNT EXCEEDS NOPT=1000 THE C ROUTINE TERMINATES. C C OPTIONS.. C C KEY=1 C COMPUTE IN W(*,*) THE N BY N C COVARIANCE MATRIX OF THE SOLUTION VARIABLES C AS AN OUTPUT PARAMTER. NOMINALLY THE C COVARIANCE MATRIX WILL NOT BE COMPUTED. C (THIS REQUIRES NO USER INPUT.) C THE DATA SET FOR THIS OPTION IS A SINGLE VALUE. C IT MUST BE NONZERO WHEN THE COVARIANCE MATRIX C IS DESIRED. IF IT IS ZERO, THE COVARIANCE C MATRIX IS NOT COMPUTED. WHEN THE COVARIANCE MATRIX C IS COMPUTED, THE FIRST DIMENSIONING PARAMETER C OF THE ARRAY W(*,*) MUST SATISFY MDW.GE.MAX0(M,N). C C KEY=2 C SCALE THE NONZERO COLUMNS OF THE C ENTIRE DATA MATRIX. C (E) C (A) C (G) C C TO HAVE LENGTH ONE. THE DATA SET FOR THIS C OPTION IS A SINGLE VALUE. IT MUST BE C NONZERO IF UNIT LENGTH COLUMN SCALING C IS DESIRED. C C KEY=3 C SCALE COLUMNS OF THE ENTIRE DATA MATRIX C (E) C (A) C (G) C C WITH A USER-PROVIDED DIAGONAL MATRIX. C THE DATA SET FOR THIS OPTION CONSISTS C OF THE N DIAGONAL SCALING FACTORS, ONE FOR C EACH MATRIX COLUMN. C C KEY=4 C CHANGE THE RANK DETERMINATION TOLERANCE FOR C THE EQUALITY CONSTRAINT EQUATIONS FROM C THE NOMINAL VALUE OF SQRT(SRELPR). THIS QUANTITY C CAN BE NO SMALLER THAN SRELPR, THE ARITHMETIC- C STORAGE PRECISION. THE QUANTITY SRELPR IS THE C LARGEST POSITIVE NUMBER SUCH THAT T=1.+SRELPR C SATISFIES T.EQ.1. THE QUANTITY USED C HERE IS INTERNALLY RESTRICTED TO BE AT C LEAST SRELPR. THE DATA SET FOR THIS OPTION C IS THE NEW TOLERANCE. C C KEY=5 C CHANGE THE RANK DETERMINATION TOLERANCE FOR C THE REDUCED LEAST SQUARES EQUATIONS FROM C THE NOMINAL VALUE OF SQRT(SRELPR). THIS QUANTITY C CAN BE NO SMALLER THAN SRELPR, THE ARITHMETIC- C STORAGE PRECISION. THE QUANTITY USED C HERE IS INTERNALLY RESTRICTED TO BE AT C LEAST SRELPR. THE DATA SET FOR THIS OPTION C IS THE NEW TOLERANCE. C C FOR EXAMPLE, SUPPOSE WE WANT TO CHANGE C THE TOLERANCE FOR THE REDUCED LEAST SQUARES C PROBLEM, COMPUTE THE COVARIANCE MATRIX OF C THE SOLUTION PARAMETERS, AND PROVIDE C COLUMN SCALING FOR THE DATA MATRIX. FOR C THESE OPTIONS THE DIMENSION OF PRGOPT(*) C MUST BE AT LEAST N+9. THE FORTRAN STATEMENTS C DEFINING THESE OPTIONS WOULD BE AS FOLLOWS. C C PRGOPT(1)=4 (LINK TO ENTRY 4 IN PRGOPT(*)) C PRGOPT(2)=1 (COVARIANCE MATRIX KEY) C PRGOPT(3)=1 (COVARIANCE MATRIX WANTED) C C PRGOPT(4)=7 (LINK TO ENTRY 7 IN PRGOPT(*)) C PRGOPT(5)=5 (LEAST SQUARES EQUAS. TOLERANCE KEY) C PRGOPT(6)=... (NEW VALUE OF THE TOLERANCE) C C PRGOPT(7)=N+9 (LINK TO ENTRY N+9 IN PRGOPT(*)) C PRGOPT(8)=3 (USER-PROVIDED COLUMN SCALING KEY) C C CALL SCOPY(N,D,1,PRGOPT(9),1) (COPY THE N C SCALING FACTORS FROM THE USER ARRAY D(*) C TO PRGOPT(9)-PRGOPT(N+8)) C C PRGOPT(N+9)=1 (NO MORE OPTIONS TO CHANGE) C C THE CONTENTS OF PRGOPT(*) ARE NOT MODIFIED C BY THE SUBPROGRAM. C THE KEY 8 AND 9 OPTIONS FOR WNNLS( ) CAN ALSO C BE INCLUDED IN THIS ARRAY. THEIR FUNCTIONS C ARE DOCUMENTED IN THE USAGE INSTRUCTIONS FOR C SUBPROGRAM WNNLS( ). C C OUTPUT.. C C X(*),RNORME, THE ARRAY X(*) CONTAINS THE SOLUTION PARAMETERS C RNORML IF THE INTEGER OUTPUT FLAG MODE = 0 OR 1. C THE DEFINITION OF MODE IS GIVEN DIRECTLY BELOW. C WHEN MODE = 0 OR 1, RNORME AND RNORML C RESPECTIVELY CONTAIN THE RESIDUAL VECTOR C EUCLIDEAN LENGTHS OF F - EX AND B - AX. WHEN C MODE=1 THE EQUALITY CONSTRAINT EQUATIONS EX=F C ARE CONTRADICTORY, SO RNORME.NE.0. THE RESIDUAL C VECTOR F-EX HAS MINIMAL EUCLIDEAN LENGTH. FOR C MODE.GE.2, NONE OF THESE PARAMETERS ARE C DEFINED. C C MODE INTEGER FLAG THAT INDICATES THE SUBPROGRAM C STATUS AFTER COMPLETION. IF MODE.GE.2, NO C SOLUTION HAS BEEN COMPUTED. C C MODE = C C 0 BOTH EQUALITY AND INEQUALITY CONSTRAINTS C ARE COMPATIBLE AND HAVE BEEN SATISFIED. C C 1 EQUALITY CONSTRAINTS ARE CONTRADICTORY. C A GENERALIZED INVERSE SOLUTION OF EX=F WAS USED C TO MINIMIZE THE RESIDUAL VECTOR LENGTH F-EX. C IN THIS SENSE, THE SOLUTION IS STILL MEANINGFUL. C C 2 NO SOLUTION COULD BE OBTAINED. THE CONSTRAINTS C ARE CONTRADICTORY. C C 4 USAGE ERROR OCCURRED. THE VALUE C OF MDW IS .LT. ME+MA+MG, MDW IS C .LT. N AND A COVARIANCE MATRIX IS C REQUESTED, OR THE OPTION VECTOR C PRGOPT(*) IS NOT PROPERLY DEFINED. C C W(*,*) THE ARRAY W(*,*) CONTAINS THE N BY N SYMMETRIC C COVARIANCE MATRIX OF THE SOLUTION PARAMETERS, C PROVIDED THIS WAS REQUESTED ON INPUT WITH C THE OPTION VECTOR PRGOPT(*) AND THE OUTPUT C FLAG IS RETURNED WITH MODE = 0 OR 1. C C IP(*) THE INTEGER WORKING ARRAY HAS THREE ENTRIES C THAT PROVIDE RANK AND WORKING ARRAY LENGTH C INFORMATION AFTER COMPLETION. C C IP(1) = RANK OF EQUALITY CONSTRAINT C MATRIX. DEFINE THIS QUANTITY C AS KRANKE. C C IP(2) = RANK OF REDUCED LEAST SQUARES C PROBLEM. C C IP(3) = THE AMOUNT OF STORAGE IN THE C WORKING ARRAY WS(*) THAT WAS C ACTUALLY USED BY THE SUBPROGRAM. C THE FORMULA GIVEN ABOVE FOR THE LENGTH C OF WS(*) IS A NECESSARY OVERESTIMATE. C USER DESIGNATED C WORKING ARRAYS.. C C WS(*),IP(*) THESE ARE RESPECTIVELY TYPE REAL C AND TYPE INTEGER WORKING ARRAYS. C THEIR REQUIRED MINIMAL LENGTHS ARE C GIVEN ABOVE. C C C SUBROUTINES CALLED C C LSI PART OF THIS PACKAGE. SOLVES A C CONSTRAINED LEAST SQUARES PROBLEM WITH C INEQUALITY CONSTRAINTS. C C SDOT,SSCAL, SUBROUTINES FROM THE BLAS PACKAGE. C SAXPY,SASUM, SEE TRANS. MATH SOFTWARE (5), P. 308. C SCOPY,SNRM2, C SSWAP,ISAMAX C C H12 SUBROUTINE TO CONSTRUCT AND APPLY A C HOUSEHOLDER TRANSFORMATION. C C SPMPAR FUNCTION TO COMPUTE THE RELATIVE MACHINE C PRECISION. C C REVISED OCT. 1, 1989. C REAL W(MDW,*), PRGOPT(*), X(*), WS(*) INTEGER IP(*) LOGICAL COV DATA ZERO /0.E0/, ONE /1.E0/, HALF /0.5E0/ C C COMPUTE MACHINE PRECISION C SRELPR = SPMPAR(1) C C COMPUTE NUMBER OF POSSIBLE RIGHT MULTIPLYING HOUSEHOLDER C TRANSFORMATIONS. C M = ME + MA + MG MODE = 0 IF (N .LE. 0 .OR. ME + MA .LE. 0) RETURN IF (.NOT.(MDW.LT.M)) GO TO 80 MODE = 4 RETURN 80 NP1 = N + 1 KRANKE = MIN0(ME,N) N1 = 2*KRANKE + 1 N2 = N1 + N C C PROCESS-OPTION-VECTOR C GO TO 480 90 IF (.NOT.(COV .AND. MDW.LT.N)) GO TO 100 MODE = 4 RETURN 100 L = KRANKE C C COMPUTE NORM OF EQUALITY CONSTRAINT MATRIX AND RT SIDE. C ENORM = ZERO DO 110 J = 1,N ENORM = AMAX1(ENORM,SASUM(ME,W(1,J),1)) 110 CONTINUE FNORM = SASUM(ME,W(1,NP1),1) IF (.NOT.(L.GT.0)) GO TO 200 SNMAX = ZERO RNMAX = ZERO DO 180 I = 1,L C C COMPUTE MAXIMUM RATIO OF VECTOR LENGTHS. PARTITION C IS AT COL. I. DO 150 K = I,ME SN = SDOT(N-I+1,W(K,I),MDW,W(K,I),MDW) RN = SDOT(I-1,W(K,1),MDW,W(K,1),MDW) IF (.NOT.(RN.EQ.ZERO .AND. SN.GT.SNMAX)) GO TO 120 SNMAX = SN IMAX = K GO TO 150 120 IF (.NOT.(K.EQ.I .OR. (SN*RNMAX.GT.RN*SNMAX))) GO TO 150 SNMAX = SN RNMAX = RN IMAX = K 150 CONTINUE C C INTERCHANGE ROWS IF NECESSARY. IF (I.NE.IMAX) CALL SSWAP(NP1, W(I,1), MDW, W(IMAX,1), MDW) IF (.NOT.(SNMAX.GT.TAU**2*RNMAX)) GO TO 160 C C ELIMINATE ELEMS I+1,...,N IN ROW I. CALL H12(1, I, I+1, N, W(I,1), MDW, WS(I), W(I+1,1), MDW, 1, * M-I) GO TO 180 160 KRANKE = I - 1 GO TO 200 180 CONTINUE C C SAVE DIAG. TERMS OF LOWER TRAP. MATRIX. C 200 CALL SCOPY(KRANKE, W, MDW+1, WS(KRANKE+1), 1) C C USE HOUSEHOLDER TRANS FROM LEFT TO ACHIEVE KRANKE BY KRANKE UPPER C TRIANGULAR FORM. C IF (.NOT.(KRANKE.GT.0 .AND. KRANKE.LT.ME)) GO TO 220 DO 210 KK = 1,KRANKE K = KRANKE + 1 - KK C C APPLY TRANFORMATION TO MATRIX COLS. 1,...,K-1. CALL H12(1, K, KRANKE+1, ME, W(1,K), 1, UP, W, 1, MDW, K-1) C C APPLY TO RT SIDE VECTOR. CALL H12(2, K, KRANKE+1, ME, W(1,K), 1, UP, W(1,NP1), 1, 1, 1) 210 CONTINUE 220 IF (.NOT.(KRANKE.GT.0)) GO TO 240 C C SOLVE FOR VARIABLES 1,...,KRANKE IN NEW COORDINATES. CALL SCOPY(KRANKE, W(1,NP1), 1, X, 1) DO 230 I=1,KRANKE X(I) = (X(I)-SDOT(I-1,W(I,1),MDW,X,1))/W(I,I) 230 CONTINUE C C COMPUTE RESIDUALS FOR REDUCED PROBLEM. C 240 MEP1 = ME + 1 RNORML = ZERO IF (.NOT.(ME.LT.M)) GO TO 270 DO 260 I = MEP1,M W(I,NP1) = W(I,NP1) - SDOT(KRANKE,W(I,1),MDW,X,1) SN = SDOT(KRANKE,W(I,1),MDW,W(I,1),MDW) RN = SDOT(N-KRANKE,W(I,KRANKE+1),MDW,W(I,KRANKE+1),MDW) IF (.NOT.(RN.LE.TAU**2*SN .AND. KRANKE.LT.N)) GO TO 260 W(I,KRANKE+1) = ZERO CALL SCOPY(N-KRANKE, W(I,KRANKE+1), 0, W(I,KRANKE+1), MDW) 260 CONTINUE C C COMPUTE EQUAL. CONSTRAINT EQUAS. RESIDUAL LENGTH. 270 RNORME = SNRM2(ME-KRANKE,W(KRANKE+1,NP1),1) C C MOVE REDUCED PROBLEM DATA UPWARD IF KRANKE.LT.ME. C IF (.NOT.(KRANKE.LT.ME)) GO TO 290 DO 280 J=1,NP1 CALL SCOPY(M-ME, W(ME+1,J), 1, W(KRANKE+1,J), 1) 280 CONTINUE C C COMPUTE SOLN OF REDUCED PROBLEM. C 290 CALL LSI(W(KRANKE+1,KRANKE+1), MDW, MA, MG, N-KRANKE, PRGOPT, * X(KRANKE+1), RNORML, MODE, WS(N2), IP(2)) IF (MODE .GT. 1) GO TO 470 IF (.NOT.(ME.GT.0)) GO TO 330 C C TEST FOR CONSISTENCY OF EQUALITY CONSTRAINTS. C MDEQC = 0 XNRME = SASUM(KRANKE,W(1,NP1),1) IF (RNORME.GT.TAU*(ENORM*XNRME+FNORM)) MDEQC = 1 MODE = MODE + MDEQC C C CHECK IF SOLN TO EQUAL. CONSTRAINTS SATISFIES INEQUAL. C CONSTRAINTS WHEN THERE ARE NO DEGREES OF FREEDOM LEFT. C IF (.NOT.(KRANKE.EQ.N .AND. MG.GT.0)) GO TO 330 XNORM = SASUM(N,X,1) MAPKE1 = MA + KRANKE + 1 MEND = MA + KRANKE + MG DO 310 I=MAPKE1,MEND SIZE = SASUM(N,W(I,1),MDW)*XNORM + ABS(W(I,NP1)) IF (.NOT.(W(I,NP1).GT.TAU*SIZE)) GO TO 310 MODE = 2 GO TO 470 310 CONTINUE 330 IF (.NOT.(KRANKE.GT.0)) GO TO 420 C C REPLACE DIAG. TERMS OF LOWER TRAP. MATRIX. CALL SCOPY(KRANKE, WS(KRANKE+1), 1, W, MDW+1) C C REAPPLY TRANS TO PUT SOLN IN ORIGINAL COORDINATES. C DO 340 II = 1,KRANKE I = KRANKE + 1 - II CALL H12(2, I, I+1, N, W(I,1), MDW, WS(I), X, 1, 1, 1) 340 CONTINUE C C COMPUTE COV MATRIX OF EQUAL. CONSTRAINED PROBLEM. C IF (.NOT.(COV)) GO TO 450 DO 400 JJ=1,KRANKE J = KRANKE + 1 - JJ IF (.NOT.(J.LT.N)) GO TO 400 RB = WS(J)*W(J,J) IF (RB.NE.ZERO) RB = ONE/RB JP1 = J + 1 DO 350 I=JP1,N W(I,J) = SDOT(N-J,W(I,JP1),MDW,W(J,JP1),MDW)*RB 350 CONTINUE GAM = SDOT(N-J,W(JP1,J),1,W(J,JP1),MDW)*RB GAM = HALF*GAM CALL SAXPY(N-J, GAM, W(J,JP1), MDW, W(JP1,J), 1) DO 370 I=JP1,N DO 360 K=I,N W(I,K) = W(I,K) + W(J,I)*W(K,J) + W(I,J)*W(J,K) W(K,I) = W(I,K) 360 CONTINUE 370 CONTINUE UJ = WS(J) VJ = GAM*UJ W(J,J) = UJ*VJ + UJ*VJ DO 380 I=JP1,N W(J,I) = UJ*W(I,J) + VJ*W(J,I) 380 CONTINUE CALL SCOPY(N-J, W(J,JP1), MDW, W(JP1,J), 1) 400 CONTINUE C C APPLY THE SCALING TO THE COVARIANCE MATRIX. C 420 IF (.NOT.(COV)) GO TO 450 DO 430 I = 1,N L = N1 + I CALL SSCAL(N, WS(L-1), W(I,1), MDW) CALL SSCAL(N, WS(L-1), W(1,I), 1) 430 CONTINUE C C RESCALE SOLN. VECTOR. C 450 IF (MODE .GT. 1) GO TO 470 DO 460 J = 1,N L = N1 + J X(J) = X(J)*WS(L-1) 460 CONTINUE 470 IP(1) = KRANKE IP(3) = IP(3) + 2*KRANKE + N RETURN 480 CONTINUE C TO PROCESS-OPTION-VECTOR C C THE NOMINAL TOLERANCE USED IN THE CODE C FOR THE EQUALITY CONSTRAINT EQUATIONS. TAU = SQRT(SRELPR) C C THE NOMINAL COLUMN SCALING USED IN THE CODE IS C THE IDENTITY SCALING. WS(N1) = ONE CALL SCOPY(N, WS(N1), 0, WS(N1), 1) C C NO COVARIANCE MATRIX IS NOMINALLY COMPUTED. COV = .FALSE. C C DEFINE BOUND FOR NUMBER OF OPTIONS TO CHANGE. NOPT = 1000 NTIMES = 0 C C DEFINE BOUND FOR POSITIVE VALUES OF LINK. NLINK = 100000 LAST = 1 LINK = PRGOPT(1) IF (.NOT.(LINK.LE.0 .OR. LINK.GT.NLINK)) GO TO 490 MODE = 4 RETURN 490 IF (.NOT.(LINK.GT.1)) GO TO 540 NTIMES = NTIMES + 1 IF (.NOT.(NTIMES.GT.NOPT)) GO TO 500 MODE = 4 RETURN 500 KEY = PRGOPT(LAST+1) IF (KEY.EQ.1) COV = PRGOPT(LAST+2).NE.ZERO IF (.NOT.(KEY.EQ.2 .AND. PRGOPT(LAST+2).NE.ZERO)) GO TO 520 DO 510 J=1,N T = SNRM2(M,W(1,J),1) IF (T.NE.ZERO) T = ONE/T L = N1 + J WS(L-1) = T 510 CONTINUE 520 IF (KEY.EQ.3) CALL SCOPY(N, PRGOPT(LAST+2), 1, WS(N1), 1) IF (KEY.EQ.4) TAU = AMAX1(SRELPR,PRGOPT(LAST+2)) NEXT = PRGOPT(LINK) IF (.NOT.(NEXT.LE.0 .OR. NEXT.GT.NLINK)) GO TO 530 MODE = 4 RETURN 530 LAST = LINK LINK = NEXT GO TO 490 540 DO 550 J=1,N L = N1 + J CALL SSCAL(M, WS(L-1), W(1,J), 1) 550 CONTINUE GO TO 90 END SUBROUTINE LSI(W, MDW, MA, MG, N, PRGOPT, X, RNORM, MODE, WS, IP) C C THIS IS A COMPANION SUBPROGRAM TO LSEI( ). C THE DOCUMENTATION FOR LSEI( ) HAS MORE COMPLETE C USAGE INSTRUCTIONS. C WRITTEN BY R. J. HANSON, SLA. C C SOLVE.. C AX = B, A MA BY N (LEAST SQUARES EQUATIONS) C SUBJECT TO.. C C GX.GE.H, G MG BY N (INEQUALITY CONSTRAINTS) C C INPUT.. C C W(*,*) CONTAINS (A B) IN ROWS 1,...,MA+MG, COLS 1,...,N+1. C (G H) C C MDW,MA,MG,N C CONTAIN (RESP) VAR. DIMENSION OF W(*,*), C AND MATRIX DIMENSIONS. C C PRGOPT(*), C PROGRAM OPTION VECTOR. C C OUTPUT.. C C X(*),RNORM C C SOLUTION VECTOR(UNLESS MODE=2), LENGTH OF AX-B. C C MODE C =0 INEQUALITY CONSTRAINTS ARE COMPATIBLE. C =2 INEQUALITY CONSTRAINTS CONTRADICTORY. C C WS(*), C WORKING STORAGE OF DIMENSION K+N+(MG+2)*(N+7), C WHERE K=MAX(MA+MG,N). C IP(MG+2*N+1) C INTEGER WORKING STORAGE C C SUBROUTINES CALLED C C LPDP THIS SUBPROGRAM MINIMIZES A SUM OF SQUARES C OF UNKNOWNS SUBJECT TO LINEAR INEQUALITY C CONSTRAINTS. PART OF THIS PACKAGE. C C SDOT,SSCAL SUBROUTINES FROM THE BLAS PACKAGE. C SAXPY,SASUM, SEE TRANS. MATH SOFTWARE (5), P. 308. C SCOPY,SSWAP C C HFTI SOLVES AN UNCONSTRAINED LINEAR LEAST SQUARES C PROBLEM. C C H12 SUBROUTINE TO CONSTRUCT AND APPLY A HOUSEHOLDER C TRANSFORMATION. C C SPMPAR FUNCTION TO COMPUTE THE RELATIVE MACHINE C PRECISION. C REAL W(MDW,*), PRGOPT(*), X(*), WS(*), RNRM(1), OPT(7) INTEGER IP(*) LOGICAL COV C DATA ZERO /0.E0/, ONE /1.E0/, HALF /0.5E0/ C SRELPR = SPMPAR(1) MODE = 0 RNORM = ZERO M = MA + MG NP1 = N + 1 KRANK = 0 IF (N.LE.0 .OR. M.LE.0) GO TO 70 C C PROCESS-OPTION-VECTOR C GO TO 500 C C COMPUTE MATRIX NORM OF LEAST SQUARES EQUAS. C 40 ANORM = ZERO DO 50 J = 1,N ANORM = AMAX1(ANORM,SASUM(MA,W(1,J),1)) 50 CONTINUE C C SET TOL FOR HFTI( ) RANK TEST. TAU = TOL*ANORM C C COMPUTE HOUSEHOLDER ORTHOGONAL DECOMP OF MATRIX. C IF (N.GT.0) WS(1) = ZERO CALL SCOPY(N, WS, 0, WS, 1) CALL SCOPY(MA, W(1,NP1), 1, WS, 1) K = MAX0(M,N) MINMAN = MIN0(MA,N) N1 = K + 1 N2 = N1 + N CALL HFTI(W, MDW, MA, N, WS, 1, 1, TAU, KRANK, RNRM, WS(N2), * WS(N1), IP) RNORM = RNRM(1) FAC = ONE GAM = MA - KRANK IF (KRANK .LT. MA) FAC = RNORM**2/GAM GO TO 80 C C REDUCE-TO-LPDP-AND-SOLVE C 70 IP(1) = KRANK IP(2) = N + MAX0(M,N) + (MG+2)*(N+7) RETURN C C TO REDUCE-TO-LPDP-AND-SOLVE C 80 MAP1 = MA + 1 C C COMPUTE INEQ. RT-HAND SIDE FOR LPDP. C IF (.NOT.(MA.LT.M)) GO TO 260 IF (.NOT.(MINMAN.GT.0)) GO TO 160 DO 90 I = MAP1,M W(I,NP1) = W(I,NP1) - SDOT(N,W(I,1),MDW,WS,1) 90 CONTINUE DO 100 I = 1,MINMAN J = IP(I) C C APPLY PERMUTATIONS TO COLS OF INEQ. CONSTRAINT MATRIX. CALL SSWAP(MG, W(MAP1,I), 1, W(MAP1,J), 1) 100 CONTINUE C C APPLY HOUSEHOLDER TRANSFORMATIONS TO CONSTRAINT MATRIX. C IF (.NOT.(0.LT.KRANK .AND. KRANK.LT.N)) GO TO 120 DO 110 II = 1,KRANK I = KRANK + 1 - II L = N1 + I CALL H12(2, I, KRANK+1, N, W(I,1), MDW, WS(L-1), W(MAP1,1), * MDW, 1, MG) 110 CONTINUE C C COMPUTE PERMUTED INEQ. CONSTR. MATRIX TIMES R-INVERSE. C 120 DO 150 I=MAP1,M IF (.NOT.(0.LT.KRANK)) GO TO 150 DO 130 J=1,KRANK W(I,J) = (W(I,J)-SDOT(J-1,W(1,J),1,W(I,1),MDW))/W(J,J) 130 CONTINUE 150 CONTINUE C C SOLVE THE REDUCED PROBLEM WITH LPDP ALGORITHM, C THE LEAST PROJECTED DISTANCE PROBLEM. C 160 CALL LPDP(W(MAP1,1), MDW, MG, KRANK, N-KRANK, OPT, X, XNORM, * MDLPDP, WS(N2), IP(N+1)) IF (MDLPDP .NE. 1) GO TO 240 IF (.NOT.(KRANK.GT.0)) GO TO 180 C C COMPUTE SOLN IN ORIGINAL COORDINATES. C DO 170 II = 1,KRANK I = KRANK + 1 - II X(I) = (X(I)-SDOT(II-1,W(I,I+1),MDW,X(I+1),1))/W(I,I) 170 CONTINUE C C APPLY HOUSEHOLDER TRANS. TO SOLN VECTOR. C 180 IF (.NOT.(0.LT.KRANK .AND. KRANK.LT.N)) GO TO 200 DO 190 I = 1,KRANK L = N1 + I CALL H12(2, I, KRANK+1, N, W(I,1), MDW, WS(L-1), X, 1, 1, 1) 190 CONTINUE 200 IF (.NOT.(MINMAN.GT.0)) GO TO 270 C C REPERMUTE VARIABLES TO THEIR INPUT ORDER. DO 210 II=1,MINMAN I = MINMAN + 1 - II J = IP(I) CALL SSWAP(1, X(I), 1, X(J), 1) 210 CONTINUE C C VARIABLES ARE NOW IN ORIG. COORDINATES. C ADD SOLN OF UNSCONSTRAINED PROB. DO 220 I = 1,N X(I) = X(I) + WS(I) 220 CONTINUE C C COMPUTE THE RESIDUAL VECTOR NORM. RNORM = SQRT(RNORM**2+XNORM**2) GO TO 270 240 MODE = 2 GO TO 270 260 CALL SCOPY(N, WS, 1, X, 1) 270 IF (.NOT.(COV .AND. KRANK.GT.0)) GO TO 70 C C COMPUTE COVARIANCE MATRIX BASED ON THE ORTHOGONAL DECOMP. C FROM HFTI( ). C KRM1 = KRANK - 1 KRP1 = KRANK + 1 C C COPY DIAG. TERMS TO WORKING ARRAY. CALL SCOPY(KRANK, W, MDW+1, WS(N2), 1) C C RECIPROCATE DIAG. TERMS. DO 280 J = 1,KRANK W(J,J) = ONE/W(J,J) 280 CONTINUE IF (.NOT.(KRANK.GT.1)) GO TO 310 C C INVERT THE UPPER TRIANGULAR QR FACTOR ON ITSELF. DO 300 I=1,KRM1 IP1 = I + 1 DO 290 J=IP1,KRANK W(I,J) = -SDOT(J-I,W(I,I),MDW,W(I,J),1)*W(J,J) 290 CONTINUE 300 CONTINUE C C COMPUTE THE INVERTED FACTOR TIMES ITS TRANSPOSE. 310 DO 330 I=1,KRANK DO 320 J=I,KRANK W(I,J) = SDOT(KRANK+1-J,W(I,J),MDW,W(J,J),MDW) 320 CONTINUE 330 CONTINUE IF (.NOT.(KRANK.LT.N)) GO TO 450 C C ZERO OUT LOWER TRAPEZOIDAL PART. C COPY UPPER TRI. TO LOWER TRI. PART. DO 340 J=1,KRANK CALL SCOPY(J, W(1,J), 1, W(J,1), MDW) 340 CONTINUE DO 350 I=KRP1,N W(I,1) = ZERO CALL SCOPY(I, W(I,1), 0, W(I,1), MDW) 350 CONTINUE C C APPLY RIGHT SIDE TRANSFORMATIONS TO LOWER TRI. N3 = N2 + KRP1 DO 430 I=1,KRANK L = N1 + I K = N2 + I RB = WS(L-1)*WS(K-1) IF (.NOT.(RB.LT.ZERO)) GO TO 420 C C IF RB.GE.ZERO, TRANSFORMATION CAN BE REGARDED AS ZERO. RB = ONE/RB C C STORE UNSCALED RANK-ONE HOUSEHOLDER UPDATE IN WORK ARRAY. WS(N3) = ZERO CALL SCOPY(N, WS(N3), 0, WS(N3), 1) L = N1 + I K = N3 + I WS(K-1) = WS(L-1) DO 360 J=KRP1,N K = N3 + J WS(K-1) = W(I,J) 360 CONTINUE DO 370 J=1,N L = N3 + I K = N3 + J WS(J) = SDOT(J-I,W(J,I),MDW,WS(L-1),1) + SDOT(N-J+1,W(J,J),1, * WS(K-1),1) WS(J) = WS(J)*RB 370 CONTINUE L = N3 + I GAM = SDOT(N-I+1,WS(L-1),1,WS(I),1)*RB GAM = GAM*HALF CALL SAXPY(N-I+1, GAM, WS(L-1), 1, WS(I), 1) DO 410 J=I,N IF (.NOT.(I.GT.1)) GO TO 390 IM1 = I - 1 K = N3 + J DO 380 L=1,IM1 W(J,L) = W(J,L) + WS(K-1)*WS(L) 380 CONTINUE 390 K = N3 + J DO 400 L=I,J IL = N3 + L W(J,L) = W(J,L) + WS(J)*WS(IL-1) + WS(L)*WS(K-1) 400 CONTINUE 410 CONTINUE 420 CONTINUE 430 CONTINUE C C COPY LOWER TRI. TO UPPER TRI. TO SYMMETRIZE THE COVARIANCE MATRIX. C DO 440 I = 1,N CALL SCOPY(I, W(I,1), MDW, W(1,I), 1) 440 CONTINUE C C REPERMUTE ROWS AND COLS. C 450 DO 470 II = 1,MINMAN I = MINMAN + 1 - II K = IP(I) IF (.NOT.(I.NE.K)) GO TO 470 CALL SSWAP(1, W(I,I), 1, W(K,K), 1) CALL SSWAP(I-1, W(1,I), 1, W(1,K), 1) CALL SSWAP(K-I-1, W(I,I+1), MDW, W(I+1,K), 1) CALL SSWAP(N-K, W(I,K+1), MDW, W(K,K+1), MDW) 470 CONTINUE C C PUT IN NORMALIZED RESIDUAL SUM OF SQUARES SCALE FACTOR C AND SYMMETRIZE THE RESULTING COVARIANCE MARIX. C DO 480 J = 1,N CALL SSCAL(J, FAC, W(1,J), 1) CALL SCOPY(J, W(1,J), 1, W(J,1), MDW) 480 CONTINUE GO TO 70 C C TO PROCESS-OPTION-VECTOR C C THE NOMINAL TOLERANCE USED IN THE CODE, 500 TOL = SQRT(SRELPR) COV = .FALSE. LAST = 1 LINK = PRGOPT(1) KEY8 = 0 KEY9 = 0 510 IF (.NOT.(LINK.GT.1)) GO TO 540 KEY = PRGOPT(LAST+1) IF (KEY .EQ. 1) COV = PRGOPT(LAST+2).NE.ZERO IF (KEY .EQ. 5) TOL = AMAX1(SRELPR,PRGOPT(LAST+2)) IF (KEY .NE. 8) GO TO 520 KEY8 = 1 EPS = PRGOPT(LAST+2) GO TO 530 520 IF (KEY .NE. 9) GO TO 530 KEY9 = 1 BLOWUP = PRGOPT(LAST+2) 530 NEXT = PRGOPT(LINK) LAST = LINK LINK = NEXT GO TO 510 C C PREPARE THE OPTION VECTOR FOR WNNLS C 540 J = 1 IF (KEY8 .EQ. 0) GO TO 550 OPT(1) = 4.0 OPT(2) = 8.0 OPT(3) = EPS J = 4 550 IF (KEY9 .EQ. 0) GO TO 560 OPT(J) = J + 3 OPT(J+1) = 9.0 OPT(J+2) = BLOWUP J = J + 3 560 OPT(J) = 1.0 GO TO 40 END SUBROUTINE LPDP(A, MDA, M, N1, N2, PRGOPT, X, WNORM, MODE, WS, IS) C C DIMENSION A(MDA,N+1),PRGOPT(*),X(N),WS((M+2)*(N+7)),IS(M+N+1), C WHERE N=N1+N2. THIS IS A SLIGHT OVERESTIMATE FOR WS(*). C C WRITTEN BY R. J. HANSON AND K. H. HASKELL, SANDIA LABS C C DETERMINE AN N1-VECTOR W, AND C AN N2-VECTOR Z C WHICH MINIMIZES THE EUCLIDEAN LENGTH OF W C SUBJECT TO G*W+H*Z .GE. Y. C THIS IS THE LEAST PROJECTED DISTANCE PROBLEM, LPDP. C THE MATRICES G AND H ARE OF RESPECTIVE C DIMENSIONS M BY N1 AND M BY N2. C C CALLED BY SUBPROGRAM LSI( ). C C THE MATRIX C (G H Y) C C OCCUPIES ROWS 1,...,M AND COLS 1,...,N1+N2+1 OF A(*,*). C C THE SOLUTION (W) IS RETURNED IN X(*). C (Z) C C THE VALUE OF MODE INDICATES THE STATUS OF C THE COMPUTATION AFTER RETURNING TO THE USER. C C MODE=1 THE SOLUTION WAS SUCCESSFULLY OBTAINED. C C MODE=2 THE INEQUALITIES ARE INCONSISTENT. C C SUBROUTINES CALLED C C WNNLS SOLVES A NONNEGATIVELY CONSTRAINED LINEAR LEAST C SQUARES PROBLEM WITH LINEAR EQUALITY CONSTRAINTS. C PART OF THIS PACKAGE. C C SDOT,SCOPY SUBROUTINES FROM THE BLAS PACKAGE. C SSCAL,SNRM2 SEE TRANS. MATH SOFTWARE (5), P. 308. C DIMENSION A(MDA,*), PRGOPT(*), X(*), WS(*), IS(*) DATA ZERO, ONE /0.E0,1.E0/, FAC /0.1E0/ C N = N1 + N2 MODE = 1 IF (.NOT.(M.LE.0)) GO TO 20 IF (.NOT.(N.GT.0)) GO TO 10 X(1) = ZERO CALL SCOPY(N, X, 0, X, 1) 10 WNORM = ZERO RETURN 20 NP1 = N + 1 C C SCALE NONZERO ROWS OF INEQUALITY MATRIX TO HAVE LENGTH ONE. C DO 40 I = 1,M SC = SNRM2(N,A(I,1),MDA) IF (SC .EQ. ZERO) GO TO 40 SC = ONE/SC CALL SSCAL(NP1, SC, A(I,1), MDA) 40 CONTINUE C C SCALE RT.-SIDE VECTOR TO HAVE LENGTH ONE (OR ZERO). YNORM = SNRM2(M,A(1,NP1),1) IF (YNORM .EQ. ZERO) GO TO 50 SC = ONE/YNORM CALL SSCAL(M, SC, A(1,NP1), 1) C C SCALE COLS OF MATRIX H. 50 J = N1 + 1 60 IF (J .GT. N) GO TO 70 SC = SNRM2(M,A(1,J),1) IF (SC .NE. ZERO) SC = ONE/SC CALL SSCAL(M, SC, A(1,J), 1) X(J) = SC J = J + 1 GO TO 60 70 IF (.NOT.(N1.GT.0)) GO TO 130 C C COPY TRANSPOSE OF (H G Y) TO WORK ARRAY WS(*). IW = 0 DO 80 I=1,M C C MOVE COL OF TRANSPOSE OF H INTO WORK ARRAY. CALL SCOPY(N2, A(I,N1+1), MDA, WS(IW+1), 1) IW = IW + N2 C C MOVE COL OF TRANSPOSE OF G INTO WORK ARRAY. CALL SCOPY(N1, A(I,1), MDA, WS(IW+1), 1) IW = IW + N1 C C MOVE COMPONENT OF VECTOR Y INTO WORK ARRAY. WS(IW+1) = A(I,NP1) IW = IW + 1 80 CONTINUE WS(IW+1) = ZERO CALL SCOPY(N, WS(IW+1), 0, WS(IW+1), 1) IW = IW + N WS(IW+1) = ONE IW = IW + 1 C C SOLVE EU=F SUBJECT TO (TRANSPOSE OF H)U=0, U.GE.0. THE C MATRIX E = TRANSPOSE OF (G Y), AND THE (N+1)-VECTOR C F = TRANSPOSE OF (0,...,0,1). IX = IW + 1 IW = IW + M CALL WNNLS(WS, NP1, N2, NP1-N2, M, 0, PRGOPT, WS(IX), RNORM, * MODEW, IS, WS(IW+1)) C C COMPUTE THE COMPONENTS OF THE SOLN DENOTED ABOVE BY W. SC = ONE - SDOT(M,A(1,NP1),1,WS(IX),1) IF (.NOT.(ONE+FAC*ABS(SC).NE.ONE .AND. RNORM.GT.ZERO)) GO TO 110 SC = ONE/SC DO 90 J=1,N1 X(J) = SC*SDOT(M,A(1,J),1,WS(IX),1) 90 CONTINUE C C COMPUTE THE VECTOR Q=Y-GW. OVERWRITE Y WITH THIS VECTOR. DO 100 I=1,M A(I,NP1) = A(I,NP1) - SDOT(N1,A(I,1),MDA,X,1) 100 CONTINUE GO TO 130 110 MODE = 2 RETURN 130 IF (.NOT.(N2.GT.0)) GO TO 180 C C COPY TRANSPOSE OF (H Q) TO WORK ARRAY WS(*). IW = 0 DO 140 I=1,M CALL SCOPY(N2, A(I,N1+1), MDA, WS(IW+1), 1) IW = IW + N2 WS(IW+1) = A(I,NP1) IW = IW + 1 140 CONTINUE WS(IW+1) = ZERO CALL SCOPY(N2, WS(IW+1), 0, WS(IW+1), 1) IW = IW + N2 WS(IW+1) = ONE IW = IW + 1 IX = IW + 1 IW = IW + M C C SOLVE RV=S SUBJECT TO V.GE.0. THE MATRIX R =(TRANSPOSE C OF (H Q)), WHERE Q=Y-GW. THE (N2+1)-VECTOR S =(TRANSPOSE C OF (0,...,0,1)). C CALL WNNLS(WS, N2+1, 0, N2+1, M, 0, PRGOPT, WS(IX), RNORM, MODEW, * IS, WS(IW+1)) C C COMPUTE THE COMPONENTS OF THE SOLN DENOTED ABOVE BY Z. C SC = ONE - SDOT(M,A(1,NP1),1,WS(IX),1) IF (.NOT.(ONE+FAC*ABS(SC).NE.ONE .AND. RNORM.GT.ZERO)) GO TO 160 SC = ONE/SC DO 150 J=1,N2 L = N1 + J X(L) = SC*SDOT(M,A(1,L),1,WS(IX),1)*X(L) 150 CONTINUE GO TO 180 160 MODE = 2 RETURN C C ACCOUNT FOR SCALING OF RT.-SIDE VECTOR IN SOLUTION. 180 CALL SSCAL(N, YNORM, X, 1) WNORM = SNRM2(N1,X,1) RETURN END SUBROUTINE WNNLS(W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, MODE, * IWORK, WORK) C C DIMENSION W(MDW,N+1),PRGOPT(*),X(N),IWORK(M+N),WORK(M+5*N) C C ABSTRACT C C THIS SUBPROGRAM SOLVES A LINEARLY CONSTRAINED LEAST SQUARES C PROBLEM. SUPPOSE THERE ARE GIVEN MATRICES E AND A OF C RESPECTIVE DIMENSIONS ME BY N AND MA BY N, AND VECTORS F C AND B OF RESPECTIVE LENGTHS ME AND MA. THIS SUBROUTINE C SOLVES THE PROBLEM C C EX = F, (EQUATIONS TO BE EXACTLY SATISFIED) C C AX = B, (EQUATIONS TO BE APPROXIMATELY SATISFIED, C IN THE LEAST SQUARES SENSE) C C SUBJECT TO COMPONENTS L+1,...,N NONNEGATIVE C C ANY VALUES ME.GE.0, MA.GE.0 AND 0.LE. L .LE.N ARE PERMITTED. C C THE PROBLEM IS REPOSED AS PROBLEM WNNLS C C (WT*E)X = (WT*F) C ( A) ( B), (LEAST SQUARES) C SUBJECT TO COMPONENTS L+1,...,N NONNEGATIVE. C C THE SUBPROGRAM CHOOSES THE HEAVY WEIGHT (OR PENALTY PARAMETER) WT. C C THE PARAMETERS FOR WNNLS ARE C C INPUT.. C C W(*,*),MDW, THE ARRAY W(*,*) IS DOUBLE SUBSCRIPTED WITH FIRST C ME,MA,N,L DIMENSIONING PARAMETER EQUAL TO MDW. FOR THIS C DISCUSSION LET US CALL M = ME + MA. THEN MDW C MUST SATISFY MDW.GE.M. THE CONDITION MDW.LT.M C IS AN ERROR. C C THE ARRAY W(*,*) CONTAINS THE MATRICES AND VECTORS C C (E F) C (A B) C C IN ROWS AND COLUMNS 1,...,M AND 1,...,N+1 C RESPECTIVELY. COLUMNS 1,...,L CORRESPOND TO C UNCONSTRAINED VARIABLES X(1),...,X(L). THE C REMAINING VARIABLES ARE CONSTRAINED TO BE C NONNEGATIVE. THE CONDITION L.LT.0 .OR. L.GT.N IS C AN ERROR. C C PRGOPT(*) THIS ARRAY IS THE OPTION VECTOR. C IF THE USER IS SATISFIED WITH THE NOMINAL C SUBPROGRAM FEATURES SET C C PRGOPT(1)=1 (OR PRGOPT(1)=1.0) C C OTHERWISE PRGOPT(*) IS A LINKED LIST CONSISTING OF C GROUPS OF DATA OF THE FOLLOWING FORM C C LINK C KEY C DATA SET C C THE PARAMETERS LINK AND KEY ARE EACH ONE WORD. C THE DATA SET CAN BE COMPRISED OF SEVERAL WORDS. C THE NUMBER OF ITEMS DEPENDS ON THE VALUE OF KEY. C THE VALUE OF LINK POINTS TO THE FIRST C ENTRY OF THE NEXT GROUP OF DATA WITHIN C PRGOPT(*). THE EXCEPTION IS WHEN THERE ARE C NO MORE OPTIONS TO CHANGE. IN THAT C CASE LINK=1 AND THE VALUES KEY AND DATA SET C ARE NOT REFERENCED. THE GENERAL LAYOUT OF C PRGOPT(*) IS AS FOLLOWS. C C ...PRGOPT(1)=LINK1 (LINK TO FIRST ENTRY OF NEXT GROUP) C . PRGOPT(2)=KEY1 (KEY TO THE OPTION CHANGE) C . PRGOPT(3)=DATA VALUE (DATA VALUE FOR THIS CHANGE) C . . C . . C . . C ...PRGOPT(LINK1)=LINK2 (LINK TO THE FIRST ENTRY OF C . NEXT GROUP) C . PRGOPT(LINK1+1)=KEY2 (KEY TO THE OPTION CHANGE) C . PRGOPT(LINK1+2)=DATA VALUE C ... . C . . C . . C ...PRGOPT(LINK)=1 (NO MORE OPTIONS TO CHANGE) C C VALUES OF LINK THAT ARE NONPOSITIVE ARE ERRORS. C A VALUE OF LINK.GT.NLINK=100000 IS ALSO AN ERROR. C THIS HELPS PREVENT USING INVALID BUT POSITIVE C VALUES OF LINK THAT WILL PROBABLY EXTEND C BEYOND THE PROGRAM LIMITS OF PRGOPT(*). C UNRECOGNIZED VALUES OF KEY ARE IGNORED. THE C ORDER OF THE OPTIONS IS ARBITRARY AND ANY NUMBER C OF OPTIONS CAN BE CHANGED WITH THE FOLLOWING C RESTRICTION. TO PREVENT CYCLING IN THE C PROCESSING OF THE OPTION ARRAY A COUNT OF THE C NUMBER OF OPTIONS CHANGED IS MAINTAINED. C WHENEVER THIS COUNT EXCEEDS NOPT=1000 THE C ROUTINE TERMINATES. C C OPTIONS.. C C KEY=6 C SCALE THE NONZERO COLUMNS OF THE C ENTIRE DATA MATRIX C (E) C (A) C TO HAVE LENGTH ONE. THE DATA SET FOR C THIS OPTION IS A SINGLE VALUE. IT MUST C BE NONZERO IF UNIT LENGTH COLUMN SCALING IS C DESIRED. C C KEY=7 C SCALE COLUMNS OF THE ENTIRE DATA MATRIX C (E) C (A) C WITH A USER-PROVIDED DIAGONAL MATRIX. C THE DATA SET FOR THIS OPTION CONSISTS C OF THE N DIAGONAL SCALING FACTORS, ONE FOR C EACH MATRIX COLUMN. C C KEY=8 C CHANGE THE RANK DETERMINATION TOLERANCE FROM C THE NOMINAL VALUE OF SQRT(EPS). THIS QUANTITY CAN C BE NO SMALLER THAN EPS, THE ARITHMETIC- C STORAGE PRECISION. THE QUANTITY USED C HERE IS INTERNALLY RESTRICTED TO BE AT C LEAST EPS. THE DATA SET FOR THIS OPTION C IS THE NEW TOLERANCE. C C KEY=9 C CHANGE THE BLOW-UP PARAMETER FROM THE C NOMINAL VALUE OF SQRT(EPS). THE RECIPROCAL OF C THIS PARAMETER IS USED IN REJECTING SOLUTION C COMPONENTS AS TOO LARGE WHEN A VARIABLE IS C FIRST BROUGHT INTO THE ACTIVE SET. TOO LARGE C MEANS THAT THE PROPOSED COMPONENT TIMES THE C RECIPROCAL OF THE PARAMETERIS NOT LESS THAN C THE RATIO OF THE NORMS OF THE RIGHT-SIDE C VECTOR AND THE DATA MATRIX. C THIS PARAMETER CAN BE NO SMALLER THAN EPS, C THE ARITHMETIC-STORAGE PRECISION. C C FOR EXAMPLE, SUPPOSE WE WANT TO PROVIDE C A DIAGONAL MATRIX TO SCALE THE PROBLEM C MATRIX AND CHANGE THE TOLERANCE USED FOR C DETERMINING LINEAR DEPENDENCE OF DROPPED COL C VECTORS. FOR THESE OPTIONS THE DIMENSIONS OF C PRGOPT(*) MUST BE AT LEAST N+6. THE FORTRAN C STATEMENTS DEFINING THESE OPTIONS WOULD C BE AS FOLLOWS. C C PRGOPT(1)=N+3 (LINK TO ENTRY N+3 IN PRGOPT(*)) C PRGOPT(2)=7 (USER-PROVIDED SCALING KEY) C C CALL SCOPY(N,D,1,PRGOPT(3),1) (COPY THE N C SCALING FACTORS FROM A USER ARRAY CALLED D(*) C INTO PRGOPT(3)-PRGOPT(N+2)) C C PRGOPT(N+3)=N+6 (LINK TO ENTRY N+6 OF PRGOPT(*)) C PRGOPT(N+4)=8 (LINEAR DEPENDENCE TOLERANCE KEY) C PRGOPT(N+5)=... (NEW VALUE OF THE TOLERANCE) C C PRGOPT(N+6)=1 (NO MORE OPTIONS TO CHANGE) C C OUTPUT.. C C X(*) AN ARRAY DIMENSIONED AT LEAST N, WHICH WILL C CONTAIN THE N COMPONENTS OF THE SOLUTION VECTOR C ON OUTPUT. C C RNORM THE RESIDUAL NORM OF THE SOLUTION. THE VALUE OF C RNORM CONTAINS THE RESIDUAL VECTOR LENGTH OF THE C EQUALITY CONSTRAINTS AND LEAST SQUARES EQUATIONS. C C MODE THE VALUE OF MODE INDICATES THE SUCCESS OR FAILURE C OF THE SUBPROGRAM. C C MODE = 0 SUBPROGRAM COMPLETED SUCCESSFULLY. C C = 1 MAX. NUMBER OF ITERATIONS (EQUAL TO C 3*(N-L)) EXCEEDED. NEARLY ALL PROBLEMS C SHOULD COMPLETE IN FEWER THAN THIS C NUMBER OF ITERATIONS. AN APPROXIMATE C SOLUTION AND ITS CORRESPONDING RESIDUAL C VECTOR LENGTH ARE IN X(*) AND RNORM. C C = 2 USAGE ERROR OCCURRED. EITHER C MDW .LT. ME + MA, L .LT. 0, L .GT. N, C OR THE OPTION VECTOR PRGOPT(*) IS C NOT PROPERLY DEFINED. C C USER-DESIGNATED C WORKING ARRAYS.. C C WORK(*) A WORKING ARRAY OF LENGTH AT LEAST C M + 5*N. C C IWORK(*) AN INTEGER-VALUED WORKING ARRAY OF LENGTH AT LEAST C M+N. C C WRITTEN BY KAREN H. HASKELL, SANDIA LABORATORIES, C AND R.J. HANSON, SANDIA LABORATORIES. C REVISED OCT. 1, 1989. C C C SUBROUTINES CALLED BY WNNLS( ) C C WNLSM COMPANION SUBROUTINE TO WNNLS( ), WHERE C MOST OF THE COMPUTATION TAKES PLACE. C C C REFERENCES C C 1. SOLVING LEAST SQUARES PROBLEMS, BY C.L. LAWSON C AND R.J. HANSON. PRENTICE-HALL, INC. (1974). C C 2. BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE, BY C C.L. LAWSON, R.J. HANSON, D.R. KINCAID, AND F.T. KROGH. C TOMS, V. 5, NO. 3, P. 308. ALSO AVAILABLE AS C SANDIA TECHNICAL REPORT NO. SAND77-0898. C C 3. AN ALGORITHM FOR LINEAR LEAST SQUARES WITH EQUALITY C AND NONNEGATIVITY CONSTRAINTS, BY K.H. HASKELL AND C R.J. HANSON. AVAILABLE AS SANDIA TECHNICAL REPORT NO. C SAND77-0552, AND MATH. PROGRAMMING, VOL. 21, (1981), P. 98-118. C REAL W(MDW,*), PRGOPT(*), X(N), WORK(*) INTEGER IWORK(*) C MODE = 0 IF (MA+ME .LE. 0 .OR. N .LE. 0) RETURN IF (.NOT.(MDW.LT.ME+MA)) GO TO 10 MODE = 2 RETURN 10 IF (0.LE.L .AND. L.LE.N) GO TO 20 MODE = 2 RETURN C C THE PURPOSE OF THIS SUBROUTINE IS TO BREAK UP THE ARRAYS C WORK(*) AND IWORK(*) INTO SEPARATE WORK ARRAYS C REQUIRED BY THE MAIN SUBROUTINE WNLSM( ). C 20 L1 = N + 1 L2 = L1 + N L3 = L2 + ME + MA L4 = L3 + N L5 = L4 + N C CALL WNLSM(W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, MODE, IWORK, * IWORK(L1), WORK(1), WORK(L1), WORK(L2), WORK(L3), WORK(L4), * WORK(L5)) RETURN END SUBROUTINE WNLSM(W, MDW, MME, MA, N, L, PRGOPT, X, RNORM, MODE, * IPIVOT, ITYPE, WD, H, SCALE, Z, TEMP, D) C C THIS IS A COMPANION SUBPROGRAM TO WNNLS( ). C THE DOCUMENTATION FOR WNNLS( ) HAS MORE COMPLETE C USAGE INSTRUCTIONS. C C WRITTEN BY KAREN H. HASKELL, SANDIA LABORATORIES, C WITH THE HELP OF R.J. HANSON, SANDIA LABORATORIES. C C IN ADDITION TO THE PARAMETERS DISCUSSED IN THE PROLOGUE TO C SUBROUTINE WNNLS, THE FOLLOWING WORK ARRAYS ARE USED IN C SUBROUTINE WNLSM (THEY ARE PASSED THROUGH THE CALLING C SEQUENCE FROM WNNLS FOR PURPOSES OF VARIABLE DIMENSIONING). C THEIR CONTENTS WILL IN GENERAL BE OF NO INTEREST TO THE USER. C C IPIVOT(*) C AN ARRAY OF LENGTH N. UPON COMPLETION IT CONTAINS THE C PIVOTING INFORMATION FOR THE COLS OF W(*,*). C C ITYPE(*) C AN ARRAY OF LENGTH M WHICH IS USED TO KEEP TRACK C OF THE CLASSIFICATION OF THE EQUATIONS. ITYPE(I)=0 C DENOTES EQUATION I AS AN EQUALITY CONSTRAINT. C ITYPE(I)=1 DENOTES EQUATION I AS A LEAST SQUARES C EQUATION. C C WD(*) C AN ARRAY OF LENGTH N. UPON COMPLETION IT CONTAINS THE C DUAL SOLUTION VECTOR. C C H(*) C AN ARRAY OF LENGTH N. UPON COMPLETION IT CONTAINS THE C PIVOT SCALARS OF THE HOUSEHOLDER TRANSFORMATIONS PERFORMED C IN THE CASE KRANK.LT.L. C C SCALE(*) C AN ARRAY OF LENGTH M WHICH IS USED BY THE SUBROUTINE C TO STORE THE DIAGONAL MATRIX OF WEIGHTS. C THESE ARE USED TO APPLY THE MODIFIED GIVENS C TRANSFORMATIONS. C C Z(*),TEMP(*) C WORKING ARRAYS OF LENGTH N. C C D(*) C AN ARRAY OF LENGTH N THAT CONTAINS THE C COLUMN SCALING FOR THE MATRIX (E). C (A) C C REAL W(MDW,*), X(*), WD(*), H(*), SCALE(*), DOPE(4) REAL Z(*), TEMP(*), PRGOPT(*), D(*), SPARAM(5) INTEGER IPIVOT(*), ITYPE(*), IDOPE(8) LOGICAL HITCON, FEASBL, DONE, POS DATA ZERO /0.E0/, ONE /1.E0/, TWO /2.E0/ C C INITIALIZE-VARIABLES C GO TO 180 C C PERFORM INITIAL TRIANGULARIZATION IN THE SUBMATRIX C CORRESPONDING TO THE UNCONSTRAINED VARIABLES USING C THE PROCEDURE INITIALLY-TRIANGULARIZE. C 10 GO TO 280 C C PERFORM WNNLS ALGORITHM USING THE FOLLOWING STEPS. C C UNTIL(DONE) C C COMPUTE-SEARCH-DIRECTION-AND-FEASIBLE-POINT C C WHEN (HITCON) ADD-CONSTRAINTS C C ELSE PERFORM-MULTIPLIER-TEST-AND-DROP-A-CONSTRAINT C C FIN C C COMPUTE-FINAL-SOLUTION C 20 IF (DONE) GO TO 80 GO TO 300 C C COMPUTE-SEARCH-DIRECTION-AND-FEASIBLE-POINT C 30 IF (.NOT.(HITCON)) GO TO 50 GO TO 370 C C WHEN (HITCON) ADD-CONSTRAINTS C 50 GO TO 640 C C ELSE PERFORM-MULTIPLIER-TEST-AND-DROP-A-CONSTRAINT C 80 GO TO 1000 C C COMPUTE-FINAL-SOLUTION C 100 CONTINUE C C TO PROCESS-OPTION-VECTOR FAC = 1.E-4 C C THE NOMINAL TOLERANCE USED IN THE CODE, TAU = SQRT(SRELPR) C C THE NOMINAL BLOW-UP FACTOR USED IN THE CODE. BLOWUP = TAU C C THE NOMINAL COLUMN SCALING USED IN THE CODE IS C THE IDENTITY SCALING. D(1) = ONE CALL SCOPY(N, D, 0, D, 1) C C DEFINE BOUND FOR NUMBER OF OPTIONS TO CHANGE. NOPT = 1000 C C DEFINE BOUND FOR POSITIVE VALUE OF LINK. NLINK = 100000 NTIMES = 0 LAST = 1 LINK = PRGOPT(1) IF (.NOT.(LINK.LE.0 .OR. LINK.GT.NLINK)) GO TO 110 MODE = 2 RETURN 110 IF (.NOT.(LINK.GT.1)) GO TO 160 NTIMES = NTIMES + 1 IF (.NOT.(NTIMES.GT.NOPT)) GO TO 120 MODE = 2 RETURN 120 KEY = PRGOPT(LAST+1) IF (.NOT.(KEY.EQ.6 .AND. PRGOPT(LAST+2).NE.ZERO)) GO TO 140 DO 130 J=1,N T = SNRM2(M,W(1,J),1) IF (T.NE.ZERO) T = ONE/T D(J) = T 130 CONTINUE 140 IF (KEY.EQ.7) CALL SCOPY(N, PRGOPT(LAST+2), 1, D, 1) IF (KEY.EQ.8) TAU = AMAX1(SRELPR,PRGOPT(LAST+2)) IF (KEY.EQ.9) BLOWUP = AMAX1(SRELPR,PRGOPT(LAST+2)) NEXT = PRGOPT(LINK) IF (.NOT.(NEXT.LE.0 .OR. NEXT.GT.NLINK)) GO TO 150 MODE = 2 RETURN 150 LAST = LINK LINK = NEXT GO TO 110 160 DO 170 J=1,N CALL SSCAL(M, D(J), W(1,J), 1) 170 CONTINUE GO TO 220 C C TO INITIALIZE-VARIABLES C C SRELPR IS THE PRECISION FOR THE MACHINE BEING USED. C 180 SRELPR = SPMPAR(1) C M = MA + MME ME = MME MEP1 = ME + 1 GO TO 100 C C PROCESS-OPTION-VECTOR 220 DONE = .FALSE. ITER = 0 ITMAX = 3*(N-L) MODE = 0 LP1 = L + 1 NSOLN = L NSP1 = NSOLN + 1 NP1 = N + 1 NM1 = N - 1 L1 = MIN0(M,L) C C COMPUTE SCALE FACTOR TO APPLY TO EQUAL. CONSTRAINT EQUAS. DO 230 J=1,N WD(J) = SASUM(M,W(1,J),1) 230 CONTINUE IMAX = ISAMAX(N,WD,1) EANORM = WD(IMAX) BNORM = SASUM(M,W(1,NP1),1) ALAMDA = EANORM/(SRELPR*FAC) C C DEFINE SCALING DIAG MATRIX FOR MOD GIVENS USAGE AND C CLASSIFY EQUATION TYPES. ALSQ = ALAMDA**2 DO 260 I=1,M C C WHEN EQU I IS HEAVILY WEIGHTED ITYPE(I)=0, ELSE ITYPE(I)=1. IF (.NOT.(I.LE.ME)) GO TO 240 T = ALSQ ITEMP = 0 GO TO 250 240 T = ONE ITEMP = 1 250 SCALE(I) = T ITYPE(I) = ITEMP 260 CONTINUE C C SET THE SOLN VECTOR X(*) TO ZERO AND THE COL INTERCHANGE C MATRIX TO THE IDENTITY. X(1) = ZERO CALL SCOPY(N, X, 0, X, 1) DO 270 I=1,N IPIVOT(I) = I 270 CONTINUE GO TO 10 280 CONTINUE C C TO INITIALLY-TRIANGULARIZE C C SET FIRST L COMPS. OF DUAL VECTOR TO ZERO BECAUSE C THESE CORRESPOND TO THE UNCONSTRAINED VARIABLES. IF (.NOT.(L.GT.0)) GO TO 290 WD(1) = ZERO CALL SCOPY(L, WD, 0, WD, 1) C C THE ARRAYS IDOPE(*) AND DOPE(*) ARE USED TO PASS C INFORMATION TO WNLIT(). THIS WAS DONE TO AVOID C A LONG CALLING SEQUENCE OR THE USE OF COMMON. 290 IDOPE(1) = ME IDOPE(2) = MEP1 IDOPE(3) = 0 IDOPE(4) = 1 IDOPE(5) = NSOLN IDOPE(6) = 0 IDOPE(7) = 1 IDOPE(8) = L1 C DOPE(1) = ALSQ DOPE(2) = EANORM DOPE(3) = FAC DOPE(4) = TAU CALL WNLIT(W, MDW, M, N, L, IPIVOT, ITYPE, H, SCALE, RNORM, * IDOPE, DOPE, DONE) ME = IDOPE(1) MEP1 = IDOPE(2) KRANK = IDOPE(3) KRP1 = IDOPE(4) NSOLN = IDOPE(5) NIV = IDOPE(6) NIV1 = IDOPE(7) L1 = IDOPE(8) GO TO 20 300 CONTINUE C C TO COMPUTE-SEARCH-DIRECTION-AND-FEASIBLE-POINT C C SOLVE THE TRIANGULAR SYSTEM OF CURRENTLY NON-ACTIVE C VARIABLES AND STORE THE SOLUTION IN Z(*). C C SOLVE-SYSTEM ASSIGN 310 TO IGO958 GO TO 1110 C C INCREMENT ITERATION COUNTER AND CHECK AGAINST MAX. NUMBER C OF ITERATIONS. 310 ITER = ITER + 1 IF (.NOT.(ITER.GT.ITMAX)) GO TO 320 MODE = 1 DONE = .TRUE. C C CHECK TO SEE IF ANY CONSTRAINTS HAVE BECOME ACTIVE. C IF SO, CALCULATE AN INTERPOLATION FACTOR SO THAT ALL C ACTIVE CONSTRAINTS ARE REMOVED FROM THE BASIS. 320 ALPHA = TWO HITCON = .FALSE. IF (.NOT.(L.LT.NSOLN)) GO TO 360 DO 350 J=LP1,NSOLN ZZ = Z(J) IF (.NOT.(ZZ.LE.ZERO)) GO TO 350 T = X(J)/(X(J)-ZZ) IF (.NOT.(T.LT.ALPHA)) GO TO 330 ALPHA = T JCON = J 330 HITCON = .TRUE. 350 CONTINUE 360 GO TO 30 370 CONTINUE C C TO ADD-CONSTRAINTS C C USE COMPUTED ALPHA TO INTERPOLATE BETWEEN LAST C FEASIBLE SOLUTION X(*) AND CURRENT UNCONSTRAINED C (AND INFEASIBLE) SOLUTION Z(*). IF (.NOT.(LP1.LE.NSOLN)) GO TO 390 DO 380 J=LP1,NSOLN X(J) = X(J) + ALPHA*(Z(J)-X(J)) 380 CONTINUE 390 FEASBL = .FALSE. GO TO 410 400 IF (FEASBL) GO TO 20 C C REMOVE COL JCON AND SHIFT COLS JCON+1 THROUGH N TO THE C LEFT. SWAP COL JCON INTO THE N-TH POSITION. THIS ACHIEVES C UPPER HESSENBERG FORM FOR THE NONACTIVE CONSTRAINTS AND C LEAVES AN UPPER HESSENBERG MATRIX TO RETRIANGULARIZE. 410 DO 420 I=1,M T = W(I,JCON) CALL SCOPY(N-JCON, W(I,JCON+1), MDW, W(I,JCON), MDW) W(I,N) = T 420 CONTINUE C C UPDATE PERMUTED INDEX VECTOR TO REFLECT THIS SHIFT AND SWAP. ITEMP = IPIVOT(JCON) IF (.NOT.(JCON.LT.N)) GO TO 440 DO 430 I=JCON,NM1 IPIVOT(I) = IPIVOT(I+1) 430 CONTINUE 440 IPIVOT(N) = ITEMP C C SIMILARLY REPERMUTE X(*) VECTOR. CALL SCOPY(N-JCON, X(JCON+1), 1, X(JCON), 1) X(N) = ZERO NSP1 = NSOLN NSOLN = NSOLN - 1 NIV1 = NIV NIV = NIV - 1 C C RETRIANGULARIZE UPPER HESSENBERG MATRIX AFTER ADDING CONSTRAINTS. J = JCON I = KRANK + JCON - L 450 IF (.NOT.(J.LE.NSOLN)) GO TO 570 IF (.NOT.(ITYPE(I).EQ.0 .AND. ITYPE(I+1).EQ.0)) GO TO 470 ASSIGN 460 TO IGO938 GO TO 620 C C (ITYPE(I).EQ.0 .AND. ITYPE(I+1).EQ.0) ZERO-IP1-TO-I-IN-COL-J 460 GO TO 560 470 IF (.NOT.(ITYPE(I).EQ.1 .AND. ITYPE(I+1).EQ.1)) GO TO 490 ASSIGN 480 TO IGO938 GO TO 620 C C (ITYPE(I).EQ.1 .AND. ITYPE(I+1).EQ.1) ZERO-IP1-TO-I-IN-COL-J 480 GO TO 560 490 IF (.NOT.(ITYPE(I).EQ.1 .AND. ITYPE(I+1).EQ.0)) GO TO 510 CALL SSWAP(NP1, W(I,1), MDW, W(I+1,1), MDW) CALL SSWAP(1, SCALE(I), 1, SCALE(I+1), 1) ITEMP = ITYPE(I+1) ITYPE(I+1) = ITYPE(I) ITYPE(I) = ITEMP C C SWAPPED ROW WAS FORMERLY A PIVOT ELT., SO IT WILL C BE LARGE ENOUGH TO PERFORM ELIM. ASSIGN 500 TO IGO938 GO TO 620 C C ZERO-IP1-TO-I-IN-COL-J 500 GO TO 560 510 IF (.NOT.(ITYPE(I).EQ.0 .AND. ITYPE(I+1).EQ.1)) GO TO 550 T = SCALE(I)*W(I,J)**2/ALSQ IF (.NOT.(T.GT.TAU**2*EANORM**2)) GO TO 530 ASSIGN 520 TO IGO938 GO TO 620 520 GO TO 540 530 CALL SSWAP(NP1, W(I,1), MDW, W(I+1,1), MDW) CALL SSWAP(1, SCALE(I), 1, SCALE(I+1), 1) ITEMP = ITYPE(I+1) ITYPE(I+1) = ITYPE(I) ITYPE(I) = ITEMP W(I+1,J) = ZERO 540 CONTINUE 550 CONTINUE 560 I = I + 1 J = J + 1 GO TO 450 C C SEE IF THE REMAINING COEFFS IN THE SOLN SET ARE FEASIBLE. THEY C SHOULD BE BECAUSE OF THE WAY ALPHA WAS DETERMINED. IF ANY ARE C INFEASIBLE IT IS DUE TO ROUNDOFF ERROR. ANY THAT ARE NON- C POSITIVE WILL BE SET TO ZERO AND REMOVED FROM THE SOLN SET. 570 IF (.NOT.(LP1.LE.NSOLN)) GO TO 590 DO 580 JCON=LP1,NSOLN IF (X(JCON).LE.ZERO) GO TO 600 580 CONTINUE 590 FEASBL = .TRUE. 600 CONTINUE GO TO 400 620 CONTINUE C C TO ZERO-IP1-TO-I-IN-COL-J IF (.NOT.(W(I+1,J).NE.ZERO)) GO TO 630 CALL SROTMG(SCALE(I), SCALE(I+1), W(I,J), W(I+1,J), SPARAM) W(I+1,J) = ZERO CALL SROTM(NP1-J, W(I,J+1), MDW, W(I+1,J+1), MDW, SPARAM) 630 GO TO 1290 C C TO PERFORM-MULTIPLIER-TEST-AND-DROP-A-CONSTRAINT C 640 CALL SCOPY(NSOLN, Z, 1, X, 1) IF (.NOT.(NSOLN.LT.N)) GO TO 650 X(NSP1) = ZERO CALL SCOPY(N-NSOLN, X(NSP1), 0, X(NSP1), 1) 650 I = NIV1 660 IF (.NOT.(I.LE.ME)) GO TO 690 C C RECLASSIFY LEAST SQUARES EQATIONS AS EQUALITIES AS C NECESSARY. IF (.NOT.(ITYPE(I).EQ.0)) GO TO 670 I = I + 1 GO TO 680 670 CALL SSWAP(NP1, W(I,1), MDW, W(ME,1), MDW) CALL SSWAP(1, SCALE(I), 1, SCALE(ME), 1) ITEMP = ITYPE(I) ITYPE(I) = ITYPE(ME) ITYPE(ME) = ITEMP MEP1 = ME ME = ME - 1 680 GO TO 660 C C FORM INNER PRODUCT VECTOR WD(*) OF DUAL COEFFS. 690 IF (.NOT.(NSP1.LE.N)) GO TO 730 DO 720 J=NSP1,N SM = ZERO IF (.NOT.(NSOLN.LT.M)) GO TO 710 DO 700 I=NSP1,M SM = SM + SCALE(I)*W(I,J)*W(I,NP1) 700 CONTINUE 710 WD(J) = SM 720 CONTINUE 730 GO TO 750 740 IF (POS .OR. DONE) GO TO 970 C C FIND J SUCH THAT WD(J)=WMAX IS MAXIMUM. THIS DETERMINES C THAT THE INCOMING COL J WILL REDUCE THE RESIDUAL VECTOR C AND BE POSITIVE. 750 WMAX = ZERO IWMAX = NSP1 IF (.NOT.(NSP1.LE.N)) GO TO 780 DO 770 J=NSP1,N IF (.NOT.(WD(J).GT.WMAX)) GO TO 760 WMAX = WD(J) IWMAX = J 760 CONTINUE 770 CONTINUE 780 IF (.NOT.(WMAX.LE.ZERO)) GO TO 790 DONE = .TRUE. GO TO 960 C C SET DUAL COEFF TO ZERO FOR INCOMING COL. 790 WD(IWMAX) = ZERO C C WMAX .GT. ZERO, SO OKAY TO MOVE COL IWMAX TO SOLN SET. C PERFORM TRANSFORMATION TO RETRIANGULARIZE, AND TEST C FOR NEAR LINEAR DEPENDENCE. C SWAP COL IWMAX INTO NSOLN-TH POSITION TO MAINTAIN UPPER C HESSENBERG FORM OF ADJACENT COLS, AND ADD NEW COL TO C TRIANGULAR DECOMPOSITION. NSOLN = NSP1 NSP1 = NSOLN + 1 NIV = NIV1 NIV1 = NIV + 1 IF (.NOT.(NSOLN.NE.IWMAX)) GO TO 800 CALL SSWAP(M, W(1,NSOLN), 1, W(1,IWMAX), 1) WD(IWMAX) = WD(NSOLN) WD(NSOLN) = ZERO ITEMP = IPIVOT(NSOLN) IPIVOT(NSOLN) = IPIVOT(IWMAX) IPIVOT(IWMAX) = ITEMP C C REDUCE COL NSOLN SO THAT THE MATRIX OF NONACTIVE C CONSTRAINTS VARIABLES IS TRIANGULAR. 800 J = M 810 IF (.NOT.(J.GT.NIV)) GO TO 870 JM1 = J - 1 JP = JM1 C C WHEN OPERATING NEAR THE ME LINE, TEST TO SEE IF THE PIVOT ELT. C IS NEAR ZERO. IF SO, USE THE LARGEST ELT. ABOVE IT AS THE PIVOT. C THIS IS TO MAINTAIN THE SHARP INTERFACE BETWEEN WEIGHTED AND C NON-WEIGHTED ROWS IN ALL CASES. IF (.NOT.(J.EQ.MEP1)) GO TO 850 IMAX = ME AMAX = SCALE(ME)*W(ME,NSOLN)**2 820 IF (.NOT.(JP.GE.NIV)) GO TO 840 T = SCALE(JP)*W(JP,NSOLN)**2 IF (.NOT.(T.GT.AMAX)) GO TO 830 IMAX = JP AMAX = T 830 JP = JP - 1 GO TO 820 840 JP = IMAX 850 IF (.NOT.(W(J,NSOLN).NE.ZERO)) GO TO 860 CALL SROTMG(SCALE(JP), SCALE(J), W(JP,NSOLN), W(J,NSOLN), SPARAM) W(J,NSOLN) = ZERO CALL SROTM(NP1-NSOLN, W(JP,NSP1), MDW, W(J,NSP1), MDW, SPARAM) 860 J = JM1 GO TO 810 C C SOLVE FOR Z(NSOLN)=PROPOSED NEW VALUE FOR X(NSOLN). C TEST IF THIS IS NONPOSITIVE OR TOO LARGE. C IF THIS WAS TRUE OR IF THE PIVOT TERM WAS ZERO REJECT C THE COL AS DEPENDENT. 870 IF (.NOT.(W(NIV,NSOLN).NE.ZERO)) GO TO 890 ISOL = NIV ASSIGN 880 TO IGO897 GO TO 980 C C TEST-PROPOSED-NEW-COMPONENT 880 GO TO 940 890 IF (.NOT.(NIV.LE.ME .AND. W(MEP1,NSOLN).NE.ZERO)) GO TO 920 C C TRY TO ADD ROW MEP1 AS AN ADDITIONAL EQUALITY CONSTRAINT. C CHECK SIZE OF PROPOSED NEW SOLN COMPONENT. C REJECT IT IF IT IS TOO LARGE. ISOL = MEP1 ASSIGN 900 TO IGO897 GO TO 980 C C TEST-PROPOSED-NEW-COMPONENT 900 IF (.NOT.(POS)) GO TO 910 C C SWAP ROWS MEP1 AND NIV, AND SCALE FACTORS FOR THESE ROWS. CALL SSWAP(NP1, W(MEP1,1), MDW, W(NIV,1), MDW) CALL SSWAP(1, SCALE(MEP1), 1, SCALE(NIV), 1) ITEMP = ITYPE(MEP1) ITYPE(MEP1) = ITYPE(NIV) ITYPE(NIV) = ITEMP ME = MEP1 MEP1 = ME + 1 910 GO TO 930 920 POS = .FALSE. 930 CONTINUE 940 IF (POS) GO TO 950 NSP1 = NSOLN NSOLN = NSOLN - 1 NIV1 = NIV NIV = NIV - 1 950 CONTINUE 960 GO TO 740 970 GO TO 20 980 CONTINUE C C TO TEST-PROPOSED-NEW-COMPONENT Z2 = W(ISOL,NP1)/W(ISOL,NSOLN) Z(NSOLN) = Z2 POS = Z2.GT.ZERO IF (.NOT.(Z2*EANORM.GE.BNORM .AND. POS)) GO TO 990 POS = .NOT.(BLOWUP*Z2*EANORM.GE.BNORM) 990 GO TO 1280 1000 CONTINUE C TO COMPUTE-FINAL-SOLUTION C C SOLVE SYSTEM, STORE RESULTS IN X(*). C ASSIGN 1010 TO IGO958 GO TO 1110 C SOLVE-SYSTEM 1010 CALL SCOPY(NSOLN, Z, 1, X, 1) C C APPLY HOUSEHOLDER TRANSFORMATIONS TO X(*) IF KRANK.LT.L IF (.NOT.(0.LT.KRANK .AND. KRANK.LT.L)) GO TO 1030 DO 1020 I=1,KRANK CALL H12(2, I, KRP1, L, W(I,1), MDW, H(I), X, 1, 1, 1) 1020 CONTINUE C C FILL IN TRAILING ZEROES FOR CONSTRAINED VARIABLES NOT IN SOLN. 1030 IF (.NOT.(NSOLN.LT.N)) GO TO 1040 X(NSP1) = ZERO CALL SCOPY(N-NSOLN, X(NSP1), 0, X(NSP1), 1) C C REPERMUTE SOLN VECTOR TO NATURAL ORDER. 1040 DO 1070 I=1,N J = I 1050 IF (IPIVOT(J).EQ.I) GO TO 1060 J = J + 1 GO TO 1050 1060 IPIVOT(J) = IPIVOT(I) IPIVOT(I) = J CALL SSWAP(1, X(J), 1, X(I), 1) 1070 CONTINUE C C RESCALE THE SOLN USING THE COL SCALING. DO 1080 J=1,N X(J) = X(J)*D(J) 1080 CONTINUE IF (.NOT.(NIV.LT.M)) GO TO 1100 DO 1090 I=NIV1,M T = W(I,NP1) IF (I.LE.ME) T = T/ALAMDA T = (SCALE(I)*T)*T RNORM = RNORM + T 1090 CONTINUE 1100 RNORM = SQRT(RNORM) RETURN C C TO SOLVE-SYSTEM C 1110 CONTINUE IF (.NOT.(DONE)) GO TO 1120 ISOL = 1 GO TO 1130 1120 ISOL = LP1 1130 IF (.NOT.(NSOLN.GE.ISOL)) GO TO 1270 C C COPY RT. HAND SIDE INTO TEMP VECTOR TO USE OVERWRITING METHOD. CALL SCOPY(NIV, W(1,NP1), 1, TEMP, 1) DO 1180 JJ=ISOL,NSOLN J = NSOLN - JJ + ISOL IF (.NOT.(J.GT.KRANK)) GO TO 1140 I = NIV - JJ + ISOL GO TO 1150 1140 I = J 1150 IF (.NOT.(J.GT.KRANK .AND. J.LE.L)) GO TO 1160 Z(J) = ZERO GO TO 1170 1160 Z(J) = TEMP(I)/W(I,J) CALL SAXPY(I-1, -Z(J), W(1,J), 1, TEMP, 1) 1170 CONTINUE 1180 CONTINUE C 1270 GO TO IGO958, (310, 1010) 1280 GO TO IGO897, (880, 900) 1290 GO TO IGO938, (460, 480, 500, 520) END SUBROUTINE WNLIT(W, MDW, M, N, L, IPIVOT, ITYPE, H, SCALE, RNORM, * IDOPE, DOPE, DONE) C C THIS IS A COMPANION SUBPROGRAM TO WNNLS( ). C THE DOCUMENTATION FOR WNNLS( ) HAS MORE COMPLETE C USAGE INSTRUCTIONS. C C NOTE THE M BY (N+1) MATRIX W( , ) CONTAINS THE RT. HAND SIDE C B AS THE (N+1)ST COL. C C C TRIANGULARIZE L1 BY L1 SUBSYSTEM, WHERE L1=MIN(M,L), WITH C COL INTERCHANGES. C REVISED OCT. 1, 1989 C REAL W(MDW,*), H(*), SCALE(*), DOPE(*), SPARAM(5) INTEGER ITYPE(*), IPIVOT(*), IDOPE(*) INTEGER ISAMAX LOGICAL INDEP, DONE, RECALC DATA TENM3 /1.E-3/, ZERO /0.E0/, ONE /1.E0/ C ME = IDOPE(1) MEP1 = IDOPE(2) KRANK = IDOPE(3) KRP1 = IDOPE(4) NSOLN = IDOPE(5) NIV = IDOPE(6) NIV1 = IDOPE(7) L1 = IDOPE(8) C ALSQ = DOPE(1) EANORM = DOPE(2) FAC = DOPE(3) TAU = DOPE(4) NP1 = N + 1 LB = MIN0(M-1,L) RECALC = .TRUE. RNORM = ZERO KRANK = 0 C WE SET FACTOR=1.E0 SO THAT THE HEAVY WEIGHT ALAMDA WILL BE C INCLUDED IN THE TEST FOR COL INDEPENDENCE. FACTOR = 1.E0 I = 1 IP1 = 2 LEND = L 10 IF (.NOT.(I.LE.LB)) GO TO 150 IF (.NOT.(I.LE.ME)) GO TO 130 C C SET IR TO POINT TO THE I-TH ROW. IR = I MEND = M ASSIGN 20 TO IGO996 GO TO 460 C C UPDATE-COL-SS-AND-FIND-PIVOT-COL 20 ASSIGN 30 TO IGO993 GO TO 560 C C PERFORM-COL-INTERCHANGE C C SET IC TO POINT TO I-TH COL. 30 IC = I ASSIGN 40 TO IGO990 GO TO 520 C C TEST-INDEP-OF-INCOMING-COL 40 IF (.NOT.(INDEP)) GO TO 110 C C ELIMINATE I-TH COL BELOW DIAG. USING MOD. GIVENS TRANSFORMATIONS C APPLIED TO (A B). J = M DO 100 JJ=IP1,M JM1 = J - 1 JP = JM1 IF (.NOT.(JJ.EQ.M)) GO TO 70 IF (.NOT.(I.LT.MEP1)) GO TO 80 J = MEP1 JP = I T = SCALE(JP)*W(JP,I)**2*TAU**2 IF (.NOT.(T.GT.SCALE(J)*W(J,I)**2)) GO TO 130 GO TO 80 70 IF (.NOT.(J.EQ.MEP1)) GO TO 80 J = JM1 JM1 = J - 1 JP = JM1 80 IF (.NOT.(W(J,I).NE.ZERO)) GO TO 90 CALL SROTMG(SCALE(JP), SCALE(J), W(JP,I), W(J,I), SPARAM) W(J,I) = ZERO CALL SROTM(NP1-I, W(JP,IP1), MDW, W(J,IP1), MDW, SPARAM) 90 J = JM1 100 CONTINUE GO TO 140 110 CONTINUE IF (.NOT.(LEND.GT.I)) GO TO 130 C C COL I IS DEPENDENT. SWAP WITH COL LEND. MAX = LEND C C PERFORM-COL-INTERCHANGE ASSIGN 120 TO IGO993 GO TO 560 120 CONTINUE LEND = LEND - 1 C C FIND COL IN REMAINING SET WITH LARGEST SS. MAX = ISAMAX(LEND-I+1,H(I),1) + I - 1 HBAR = H(MAX) GO TO 30 130 CONTINUE KRANK = I - 1 GO TO 160 140 I = IP1 IP1 = IP1 + 1 GO TO 10 150 KRANK = L1 160 CONTINUE KRP1 = KRANK + 1 IF (.NOT.(KRANK.LT.ME)) GO TO 290 FACTOR = ALSQ DO 170 I=KRP1,ME IF (L.GT.0) W(I,1) = ZERO CALL SCOPY(L, W(I,1), 0, W(I,1), MDW) 170 CONTINUE C C DETERMINE THE RANK OF THE REMAINING EQUALITY CONSTRAINT C EQUATIONS BY ELIMINATING WITHIN THE BLOCK OF CONSTRAINED C VARIABLES. REMOVE ANY REDUNDANT CONSTRAINTS. C IR = KRP1 IF (.NOT.(L.LT.N)) GO TO 245 LP1 = L + 1 RECALC = .TRUE. LB = MIN0(L+ME-KRANK,N) I = LP1 IP1 = I + 1 180 IF (.NOT.(I.LE.LB)) GO TO 280 IR = KRANK + I - L LEND = N MEND = ME ASSIGN 190 TO IGO996 GO TO 460 C C UPDATE-COL-SS-AND-FIND-PIVOT-COL 190 ASSIGN 200 TO IGO993 GO TO 560 C C PERFORM-COL-INTERCHANGE C C ELIMINATE ELEMENTS IN THE I-TH COL. 200 J = ME 210 IF (.NOT.(J.GT.IR)) GO TO 230 JM1 = J - 1 IF (.NOT.(W(J,I).NE.ZERO)) GO TO 220 CALL SROTMG(SCALE(JM1), SCALE(J), W(JM1,I), W(J,I), SPARAM) W(J,I) = ZERO CALL SROTM(NP1-I, W(JM1,IP1), MDW, W(J,IP1), MDW, SPARAM) 220 J = JM1 GO TO 210 C C SET IC=I=COL BEING ELIMINATED 230 IC = I ASSIGN 240 TO IGO990 GO TO 520 C C TEST-INDEP-OF-INCOMING-COL 240 IF (INDEP) GO TO 270 C C REMOVE ANY REDUNDANT OR DEPENDENT EQUALITY CONSTRAINTS. 245 CONTINUE JJ = IR 250 IF (.NOT.(IR.LE.ME)) GO TO 260 W(IR,1) = ZERO CALL SCOPY(N, W(IR,1), 0, W(IR,1), MDW) RNORM = RNORM + (SCALE(IR)*W(IR,NP1)/ALSQ)*W(IR,NP1) W(IR,NP1) = ZERO SCALE(IR) = ONE C RECLASSIFY THE ZEROED ROW AS A LEAST SQUARES EQUATION. ITYPE(IR) = 1 IR = IR + 1 GO TO 250 C C REDUCE ME TO REFLECT ANY DISCOVERED DEPENDENT EQUALITY C CONSTRAINTS. 260 CONTINUE ME = JJ - 1 MEP1 = ME + 1 GO TO 300 270 I = IP1 IP1 = IP1 + 1 GO TO 180 280 CONTINUE 290 CONTINUE 300 CONTINUE IF (.NOT.(KRANK.LT.L1)) GO TO 420 C C TRY TO DETERMINE THE VARIABLES KRANK+1 THROUGH L1 FROM THE C LEAST SQUARES EQUATIONS. CONTINUE THE TRIANGULARIZATION WITH C PIVOT ELEMENT W(MEP1,I). C RECALC = .TRUE. C C SET FACTOR=ALSQ TO REMOVE EFFECT OF HEAVY WEIGHT FROM C TEST FOR COL INDEPENDENCE. FACTOR = ALSQ KK = KRP1 I = KK IP1 = I + 1 310 IF (.NOT.(I.LE.L1)) GO TO 410 C C SET IR TO POINT TO THE MEP1-ST ROW. IR = MEP1 LEND = L MEND = M ASSIGN 320 TO IGO996 GO TO 460 C C UPDATE-COL-SS-AND-FIND-PIVOT-COL 320 ASSIGN 330 TO IGO993 GO TO 560 C C PERFORM-COL-INTERCHANGE C C ELIMINATE I-TH COL BELOW THE IR-TH ELEMENT. 330 IRP1 = IR + 1 IF (.NOT.(IRP1.LE.M)) GO TO 355 J = M DO 350 JJ=IRP1,M JM1 = J - 1 IF (.NOT.(W(J,I).NE.ZERO)) GO TO 340 CALL SROTMG(SCALE(JM1), SCALE(J), W(JM1,I), W(J,I), SPARAM) W(J,I) = ZERO CALL SROTM(NP1-I, W(JM1,IP1), MDW, W(J,IP1), MDW, SPARAM) 340 J = JM1 350 CONTINUE 355 CONTINUE C C TEST IF NEW PIVOT ELEMENT IS NEAR ZERO. IF SO, THE COL IS C DEPENDENT. T = SCALE(IR)*W(IR,I)**2 INDEP = T.GT.TAU**2*EANORM**2 IF (.NOT.INDEP) GO TO 380 C C COL TEST PASSED. NOW MUST PASS ROW NORM TEST TO BE CLASSIFIED C AS INDEPENDENT. RN = ZERO DO 370 I1=IR,M DO 360 J1=IP1,N RN = AMAX1(RN,SCALE(I1)*W(I1,J1)**2) 360 CONTINUE 370 CONTINUE INDEP = T.GT.TAU**2*RN C C IF INDEPENDENT, SWAP THE IR-TH AND KRP1-ST ROWS TO MAINTAIN THE C TRIANGULAR FORM. UPDATE THE RANK INDICATOR KRANK AND THE C EQUALITY CONSTRAINT POINTER ME. 380 IF (.NOT.(INDEP)) GO TO 390 CALL SSWAP(NP1, W(KRP1,1), MDW, W(IR,1), MDW) CALL SSWAP(1, SCALE(KRP1), 1, SCALE(IR), 1) C RECLASSIFY THE LEAST SQ. EQUATION AS AN EQUALITY CONSTRAINT AND C RESCALE IT. ITYPE(IR) = 0 T = SQRT(SCALE(KRP1)) CALL SSCAL(NP1, T, W(KRP1,1), MDW) SCALE(KRP1) = ALSQ ME = MEP1 MEP1 = ME + 1 KRANK = KRP1 KRP1 = KRANK + 1 GO TO 400 390 GO TO 430 400 I = IP1 IP1 = IP1 + 1 GO TO 310 410 CONTINUE 420 CONTINUE 430 CONTINUE C C IF PSEUDORANK IS LESS THAN L, APPLY HOUSEHOLDER TRANS. C FROM RIGHT. IF (.NOT.(KRANK.LT.L)) GO TO 450 DO 440 I=1,KRANK J = KRP1 - I CALL H12(1, J, KRP1, L, W(J,1), MDW, H(J), W, MDW, 1, J-1) 440 CONTINUE 450 NIV = KRANK + NSOLN - L NIV1 = NIV + 1 IF (L.EQ.N) DONE = .TRUE. C C END OF INITIAL TRIANGULARIZATION. IDOPE(1) = ME IDOPE(2) = MEP1 IDOPE(3) = KRANK IDOPE(4) = KRP1 IDOPE(5) = NSOLN IDOPE(6) = NIV IDOPE(7) = NIV1 IDOPE(8) = L1 RETURN 460 CONTINUE C C TO UPDATE-COL-SS-AND-FIND-PIVOT-COL C C THE COL SS VECTOR WILL BE UPDATED AT EACH STEP. WHEN C NUMERICALLY NECESSARY, THESE VALUES WILL BE RECOMPUTED. C IF (.NOT.(IR.NE.1 .AND. (.NOT.RECALC))) GO TO 480 C UPDATE COL SS =SUM OF SQUARES. DO 470 J=I,LEND H(J) = H(J) - SCALE(IR-1)*W(IR-1,J)**2 470 CONTINUE C C TEST FOR NUMERICAL ACCURACY. MAX = ISAMAX(LEND-I+1,H(I),1) + I - 1 RECALC = HBAR + TENM3*H(MAX).EQ.HBAR C C IF REQUIRED, RECALCULATE COL SS, USING ROWS IR THROUGH MEND. 480 IF (.NOT.(RECALC)) GO TO 510 DO 500 J=I,LEND H(J) = ZERO DO 490 K=IR,MEND H(J) = H(J) + SCALE(K)*W(K,J)**2 490 CONTINUE 500 CONTINUE C C FIND COL WITH LARGEST SS. MAX = ISAMAX(LEND-I+1,H(I),1) + I - 1 HBAR = H(MAX) 510 GO TO 600 520 CONTINUE C C TO TEST-INDEP-OF-INCOMING-COL C C TEST THE COL IC TO DETERMINE IF IT IS LINEARLY INDEPENDENT C OF THE COLS ALREADY IN THE BASIS. IN THE INIT TRI C STEP, WE USUALLY WANT THE HEAVY WEIGHT ALAMDA TO C BE INCLUDED IN THE TEST FOR INDEPENDENCE. IN THIS CASE THE C VALUE OF FACTOR WILL HAVE BEEN SET TO 1.E0 BEFORE THIS C PROCEDURE IS INVOKED. IN THE POTENTIALLY RANK DEFICIENT C PROBLEM, THE VALUE OF FACTOR WILL HAVE BEEN C SET TO ALSQ=ALAMDA**2 TO REMOVE THE EFFECT OF THE HEAVY WEIGHT C FROM THE TEST FOR INDEPENDENCE. C C WRITE NEW COL AS PARTITIONED VECTOR C (A1) NUMBER OF COMPONENTS IN SOLN SO FAR = NIV C (A2) M-NIV COMPONENTS C AND COMPUTE SN = INVERSE WEIGHTED LENGTH OF A1 C RN = INVERSE WEIGHTED LENGTH OF A2 C CALL THE COL INDEPENDENT WHEN RN .GT. TAU*SN SN = ZERO RN = ZERO DO 550 J=1,MEND T = SCALE(J) IF (J.LE.ME) T = T/FACTOR T = T*W(J,IC)**2 IF (.NOT.(J.LT.IR)) GO TO 530 SN = SN + T GO TO 540 530 RN = RN + T 540 CONTINUE 550 CONTINUE INDEP = RN.GT.TAU**2*SN GO TO 590 560 CONTINUE C C TO PERFORM-COL-INTERCHANGE C IF (.NOT.(MAX.NE.I)) GO TO 570 C EXCHANGE ELEMENTS OF PERMUTED INDEX VECTOR AND PERFORM COL C INTERCHANGES. ITEMP = IPIVOT(I) IPIVOT(I) = IPIVOT(MAX) IPIVOT(MAX) = ITEMP CALL SSWAP(M, W(1,MAX), 1, W(1,I), 1) T = H(MAX) H(MAX) = H(I) H(I) = T 570 GO TO IGO993, (30, 200, 330, 120) 590 GO TO IGO990, (40, 240) 600 GO TO IGO996, (20, 190, 320) END SUBROUTINE L2SLV(M, N, M1, L, A, MM, B, MB, W, TOL, N1, IPIVOT, * X, NN, RES, MR, QR, MMPNN, C, IFAULT) C ** PURPOSE ** C SUBROUTINE L2SLV COMPUTES LEAST SQUARES SOLUTIONS TO OVERDETERMINED C AND UNDERDETERMINED SYSTEMS OF LINEAR EQUATIONS. THE METHOD USED IS C A MODIFIED GRAM-SCHMIDT ORTHOGONAL DECOMPOSITION WITH ITERATIVE C REFINEMENT OF THE SOLUTION. THE SOLUTION MAY BE SUBJECT TO LINEAR C EQUALITY CONSTRAINTS. OUTPUT INCLUDES THE LEAST SQUARES C COEFFICIENTS, RESIDUALS, UNSCALED COVARIANCE MATRIX, AND INFORMATION C ON THE BEHAVIOR OF THE ITERATIVE REFINEMENT PROCEDURE. C MATRIX A IS THE GIVEN MATRIX OF A SYSTEM OF M LINEAR EQUATIONS IN N C UNKNOWNS, AND MATRIX W IS A GIVEN DIAGONAL MATRIX OF WEIGHTS WITH ALL C DIAGONAL ELEMENTS NONNEGATIVE. LET H = W*A. C IN THE EVENT THAT N1 (THE COMPUTED RANK OF MATRIX H) IS LESS THAN N C (THE NUMBER OF UNKNOWN COEFFICIENTS), A UNIQUE SOLUTION VECTOR HAVING C N ELEMENTS CAN BE OBTAINED BY IMPOSING THE CONDITION THAT THE C SOLUTION BE OF MINIMAL EUCLIDEAN NORM. SUCH A SOLUTION IS SOUGHT IN C THE CASE OF UNDERDETERMINED OR RANK-DEFICIENT PROBLEMS. C C ** INPUT VARIABLES ** C M TOTAL NUMBER OF EQUATIONS. C N NUMBER OF UNKNOWN COEFFICIENTS. C M1 NUMBER OF LINEAR CONSTRAINTS (0.LE.M1.LE.M AND M1.LE.N). C L NUMBER OF RIGHT-HAND SIDES (VECTORS OF OBSERVATIONS). C A TWO-DIMENSIONAL ARRAY OF SIZE (MM,N). ON ENTRY, THE ARRAY A C CONTAINS THE GIVEN MATRIX OF A SYSTEM OF M LINEAR EQUATIONS C IN N UNKNOWNS, WHERE THE FIRST M1 EQUATIONS ARE TO BE C SATISFIED EXACTLY. A IS LEFT INTACT ON EXIT. C B TWO-DIMENSIONAL ARRAY OF SIZE (MB,L). ON ENTRY, B CONTAINS C THE L GIVEN RIGHT-HAND SIDES (VECTORS OF OBSERVATIONS). B IS C LEFT INTACT ON EXIT. C W VECTOR OF SIZE M. ON ENTRY, W CONTAINS THE DIAGONAL ELEMENTS C OF A GIVEN DIAGONAL MATRIX OF WEIGHTS, ALL NONNEGATIVE. C (THE FIRST M1 ELEMENTS OF W ARE SET EQUAL TO 1.0 BY THE C PROGRAM WHEN M1 IS GREATER THAN ZERO.) C TOL PARAMETER USED IN DETERMINING THE RANK OF MATRIX H. C NOTE -- C (1) IF TOL EQUALS ZERO, THE TOLERANCE USED IN SUBROUTINE C DECOM2 WILL BE BASED ON MACHINE PRECISION. C (2) IF TOL IS GREATER THAN ZERO, THIS VALUE OF TOL WILL BE C USED IN SETTING AN ABSOLUTE TOLERANCE FOR COMPARISON WITH C DIAGONAL ELEMENTS OF THE TRIANGULAR MATRIX OBTAINED IN C SUBROUTINE DECOM2. THE VALUE OF TOL CAN BE BASED ON C KNOWLEDGE CONCERNING THE ACCURACY OF THE DATA. C MM DIMENSIONING PARAMETER SPECIFYING MAXIMUM NUMBER OF ROWS IN C THE ARRAY A. MM MUST SATISFY MM.GE.M. C MB DIMENSIONING PARAMETER SPECIFYING MAXIMUM NUMBER OF ROWS IN C THE ARRAY B. MB MUST SATISFY MB.GE.M. C MR DIMENSIONING PARAMETER SPECIFYING MAXIMUM NUMBER OF ROWS IN C THE ARRAY RES. MR MUST SATISFY MR.GE.M. C NN DIMENSIONING PARAMETER SPECIFYING MAXIMUM NUMBER OF ROWS IN C THE ARRAY X. NN MUST SATISFY NN.GE.N. C MMPNN DIMENSIONING PARAMETER SPECIFYING MAXIMUM NUMBER OF ROWS IN C THE ARRAY QR. MMPNN MUST SATISFY MMPNN.GE.M+N. C C ** OUTPUT VARIABLES AND INTERNAL VARIABLES ** C N1 COMPUTED RANK OF MATRIX H, WHERE H = W*A. C IPIVOT VECTOR OF SIZE N. ON EXIT, THIS ARRAY RECORDS THE ORDER C IN WHICH THE COLUMNS OF H WERE SELECTED BY THE PIVOTING C SCHEME IN THE COURSE OF THE ORTHOGONAL DECOMPOSITION. C WHENEVER N1.LT.N, THE FIRST N1 ELEMENTS OF IPIVOT INDICATE C WHICH COLUMNS OF H WERE FOUND TO BE LINEARLY INDEPENDENT. C X TWO-DIMENSIONAL ARRAY OF SIZE (NN,L). ON EXIT, X CONTAINS C THE SOLUTION VECTORS. C RES TWO-DIMENSIONAL ARRAY OF SIZE (MR,L). ON EXIT, RES CONTAINS C THE RESIDUAL VECTORS. C QR TWO-DIMENSIONAL ARRAY OF SIZE (MMPNN,N). ON EXIT, IF N1 = N C THEN QR CONTAINS THE UNSCALED COVARIANCE MATRIX. (QR IS USED C INTERNALLY TO STORE THE RESULTS FROM THE SUBROUTINE DECOM2. C THE RESULTS FROM DECOM2 ARE DESTROYED WHEN THE COVARIANCE C MATRIX IS COMPUTED.) C C VECTOR HAVING AT LEAST 6*(M+N)+2*L ELEMENTS USED (1) FOR C INTERNAL WORK SPACE AND (2) FOR RETURNING INFORMATION ON THE C BEHAVIOR OF THE ITERATIVE REFINEMENT PROCEDURE. C (A) NUMIT IS THE NUMBER OF ITERATIONS CARRIED OUT DURING THE C ITERATIVE REFINEMENT IN ATTEMPTING TO OBTAIN A SOLUTION C FOR THE K-TH RIGHT-HAND SIDE. C ON EXIT, C(K) = +NUMIT IF THE SOLUTION CONVERGED, AND C C(K) = -NUMIT IF THE SOLUTION FAILED TO CONVERGE. C (B) DIGITX GIVES AN ESTIMATE OF THE NUMBER OF CORRECT DIGITS C IN THE INITIAL SOLUTION OF THE COEFFICIENTS FOR THE K-TH C RIGHT-HAND SIDE. ON EXIT, C(K+L) = DIGITX. C IFAULT FAULT INDICATOR WHICH IS ZERO IF NO ERRORS WERE ENCOUNTERED C AND POSITIVE IF ERRORS WERE DETECTED OR IF EVIDENCE OF SEVERE C ILL-CONDITIONING WAS FOUND. IF IFAULT IS SET TO 1, 2, 3, 4, C 5, 6 OR 7, EXECUTION IS TERMINATED. EXECUTION CONTINUES WHEN C IFAULT IS SET EQUAL TO 8, 9 OR 10 PROVIDED THAT A SOLUTION C WAS OBTAINED FOR AT LEAST ONE RIGHT-HAND SIDE. THE VALUE OF C IFAULT IS USED TO INDICATE THE FOLLOWING -- C 0 = NO ERRORS ENCOUNTERED. C 1 = BAD INPUT PARAMETER (M, N OR L). C 2 = BAD INPUT PARAMETER (M1). C 3 = BAD DIMENSION. EITHER M.GT.MM, M.GT.MB, M.GT.MR, C N.GT.NN, OR M+N.GT.MMPNN. C 4 = AT LEAST ONE WEIGHT IS NEGATIVE. C 5 = EITHER MATRIX H OR MATRIX OF CONSTRAINTS EQUALS ZERO. C 6 = CONSTRAINTS ARE LINEARLY DEPENDENT. C 7 = ALL SOLUTIONS FAILED TO CONVERGE. C 8 = SOLUTION FAILED TO CONVERGE FOR AT LEAST ONE RIGHT-HAND C SIDE. C 9 = LARGE NUMBER OF ITERATIONS REQUIRED FOR CONVERGENCE. C 10 = ESTIMATED NUMBER OF DIGITS IN INITIAL SOLUTION OF C COEFFICIENTS IS SMALL. C 11 = DIAGONAL ELEMENT OF COVARIANCE MATRIX WAS COMPUTED TO BE C NEGATIVE OWING TO ROUNDING ERROR. NO SEVERE CONDITIONING C PROBLEMS WERE DETECTED. C 12 = DIAGONAL ELEMENT OF COVARIANCE MATRIX WAS COMPUTED TO BE C NEGATIVE OWING TO ROUNDING ERROR. THE PROBLEM APPEARS TO C BE EXTREMELY ILL-CONDITIONED. C C ** SUBROUTINES REQUIRED ** C SUBROUTINE DECOM2 C USES MODIFIED GRAM-SCHMIDT ALGORITHM WITH PIVOTING TO C OBTAIN AN ORTHOGONAL DECOMPOSITION OF THE INPUT MATRIX. C SUBROUTINE SOLVE2 C COMPUTES COEFFICIENTS AND RESIDUALS. ITERATIVE REFINEMENT IS C USED TO IMPROVE THE ACCURACY OF THE INITIAL SOLUTION. C SUBROUTINE SOLVE3 C CALLED ONLY BY SUBROUTINE SOLVE2. C SUBROUTINE COVAR C COMPUTES UNSCALED COVARIANCE MATRIX OF THE COEFFICIENTS. C C ** STORAGE REQUIREMENTS ** C THE STORAGE REQUIRED FOR THE DIMENSIONED ARRAYS IN L2SLV IS C M*(2*N + 2*L + 7) + N*(N + L + 7) + 2*L C LOCATIONS. ALL ARRAYS REQUIRED IN SUBROUTINES CALLED BY L2SLV ARE C DECLARED HEREIN AND ARE TRANSMITTED ONLY THROUGH PARAMETER LISTS OF C CALL-SEQUENCES. C C ** PRECISION OF ARITHMETIC CALCULATIONS ** C SINGLE PRECISION ARITHMETIC IS USED FOR ALL CALCULATIONS EXCEPT THE C DOUBLE PRECISION ACCUMULATION OF INNER PRODUCTS. (THE VARIABLE SUM C IS DECLARED TO BE DOUBLE PRECISION IN SUBROUTINES DECOM2, SOLVE2, C SOLVE3 AND COVAR.) IT IS ESSENTIAL FOR THE SUCCESS OF THE ITERATIVE C REFINEMENT PROCEDURE THAT INNER PRODUCTS BE ACCUMULATED IN DOUBLE C PRECISION. C C ** CONVERSION OF THE PROGRAM TO DOUBLE PRECISION ** C ********************************************************************* C * ON COMPUTERS HAVING SHORT WORD LENGTH (AS THE IBM 360/370) IT MAY * C * BE DESIRABLE TO PERFORM ALL CALCULATIONS IN DOUBLE PRECISION. IN * C * THIS CASE, THE ITERATIVE REFINEMENT PRESENTLY INCLUDED IN SOLVE2 * C * SHOULD BE OMITTED. * C * TO CONVERT THE PROGRAM TO DOUBLE PRECISION, THE FOLLOWING * C * APPROACH IS SUGGESTED. * C * * C * 1. VARIABLES PRESENTLY DECLARED TO BE REAL SHOULD BE DECLARED * C * DOUBLE PRECISION. THOSE TYPED INTEGER, DOUBLE PRECISION AND * C * LOGICAL SHOULD NOT BE CHANGED. * C * 2. THE USE OF FAIL, NUMIT AND DIGITX SHOULD BE OMITTED. * C * 3. DESCRIPTION OF VARIABLE C (AT L2B 690-790) SHOULD READ -- * C * C VECTOR HAVING AT LEAST 6*(M+N) ELEMENTS USED ONLY FOR * C * INTERNAL WORK SPACE. * C * 4. THE VALUE OF ETA (AT L2B 1960) SHOULD BE SET SO THAT IT IS THE * C * SMALLEST POSITIVE DOUBLE PRECISION NUMBER SUCH THAT 1.0 + ETA * C * IS GREATER THAN 1.0 IN DOUBLE PRECISION ARITHMETIC. * C * FOR IBM COMPUTER TYPE, ETA = 16.**(-13) * C * FOR UNIVAC COMPUTER TYPE, ETA = 2.**(-59) * C * 5. THE FOLLOWING FORTRAN FUNCTIONS SHOULD BE CHANGED -- * C * SINGLE PRECISION NAME DOUBLE PRECISION NAME * C * DBLE(X) X * C * FLOAT(N) DBLE(FLOAT(N)) * C * SQRT(X) DSQRT(X) * C * DBLE(X) IS USED IN SUBROUTINES DECOM2, SOLVE2, SOLVE3 AND * C * COVAR. * C * FLOAT(N) IS USED IN SUBROUTINE DECOM2. * C * SQRT(X) IS USED IN SUBROUTINE L2SLV. * C * 6. REPLACE STATEMENT L2B 2500 BY A STATEMENT READING * C * K3 = 1 * C * 7. FURTHER DETAILS ARE GIVEN IN SUBROUTINE SOLVE2 IN CONNECTION * C * WITH THE OMISSION OF ITERATIVE REFINEMENT. * C * 8. IN SUBROUTINE L2SLV, STATEMENTS L2B 950-1000, 1820-1830, 2020, * C * 2350-2360, 2480-2490, 3070, 3280-3570 AND 3590-3620 SHOULD BE * C * OMITTED. * C * STATEMENT NUMBERS GIVEN HERE REFER TO THOSE IN THE RIGHT-HAND * C * MARGIN. CERTAIN COMMENTS IN SUBROUTINE L2SLV DO NOT APPLY TO * C * THE DOUBLE PRECISION VERSION. * C * * C ********************************************************************* C INTEGER IPIVOT(N) REAL A(MM,N), B(MB,L), C(*), ETA, QR(MMPNN,N), * RES(MR,L), TOL, W(M), X(NN,L) REAL DIGITX LOGICAL FAIL LOGICAL SING C C SET VALUE OF ETA, A MACHINE-DEPENDENT PARAMETER. C ETA, THE RELATIVE MACHINE PRECISION, IS THE SMALLEST POSITIVE REAL C NUMBER SUCH THAT 1.0 + ETA IS GREATER THAN 1.0 IN FLOATING-POINT C ARITHMETIC. C ETA = SPMPAR(1) C C DEFAULT VALUE FOR TOL IS ZERO. C IF (TOL.LT.0.0) TOL = 0.0 IFAULT = 0 KSUM = 0 C C PERFORM INITIAL CHECKING OF INPUT PARAMETERS, DIMENSIONS AND C WEIGHTS FOR POSSIBLE ERRORS. C IF (M.GT.0 .AND. N.GT.0 .AND. L.GT.0) GO TO 10 IFAULT = 1 RETURN 10 IF (M1.LE.M .AND. M1.LE.N .AND. M1.GE.0) GO TO 20 IFAULT = 2 RETURN 20 IF (M.LE.MM .AND. M.LE.MB .AND. M.LE.MR .AND. N.LE.NN * .AND. M+N.LE.MMPNN) GO TO 30 IFAULT = 3 RETURN 30 DO 40 I=1,M IF (M1.GT.0 .AND. I.LE.M1) W(I) = 1.0 IF (W(I).GE.0.0) GO TO 40 IFAULT = 4 RETURN 40 CONTINUE C C SET PARAMETERS WHICH ALLOCATE VECTOR C TO CONTAIN CERTAIN FINAL C RESULTS AND ALSO TO BE USED AS WORK SPACE. C C K1 IS STARTING POINT FOR NUMIT AND FAIL, OF LENGTH L. C K2 IS STARTING POINT FOR DIGITX, OF LENGTH L. C K3 IS STARTING POINT FOR D, OF LENGTH N. C K4 IS STARTING POINT FOR K-TH COLUMN OF B, OF LENGTH M. C K5 IS STARTING POINT FOR K-TH COLUMN OF X, OF LENGTH N. C K6 IS STARTING POINT FOR K-TH COLUMN OF RES, OF LENGTH M. C K7 IS STARTING POINT FOR WORK SPACE OF LENGTH M. C K8 IS STARTING POINT FOR WORK SPACE OF LENGTH M. C K9 IS STARTING POINT FOR WORK SPACE OF LENGTH N. C K10 IS STARTING POINT FOR WORK SPACE OF LENGTH N. C K11 IS STARTING POINT FOR WORK SPACE OF LENGTH M + N. C K12 IS STARTING POINT FOR WORK SPACE OF LENGTH M + N. C K1 = 1 K2 = K1 + L K3 = K2 + L K4 = K3 + N K5 = K4 + M K6 = K5 + N K7 = K6 + M K8 = K7 + M K9 = K8 + M K10 = K9 + N K11 = K10 + N K12 = K11 + M + N K = K12 + M + N - 1 C C MULTIPLY EACH ROW OF MATRIX A (M BY N) BY ITS APPROPRIATE WEIGHT AND C STORE THE RESULT IN THE FIRST M ROWS OF ARRAY QR. SET ARRAY C AND C THE LAST N ROWS OF ARRAY QR EQUAL TO ZERO. C DO 60 I=1,K C(I) = 0.0 60 CONTINUE MP1 = M + 1 MPN = M + N DO 90 J=1,N DO 70 I=1,M QR(I,J) = A(I,J)*W(I) 70 CONTINUE DO 80 I=MP1,MPN QR(I,J) = 0.0 80 CONTINUE 90 CONTINUE C C OBTAIN AN ORTHOGONAL DECOMPOSITION OF THE MATRIX STORED IN THE FIRST C M ROWS OF ARRAY QR AND COMPUTE ITS RANK. C CALL DECOM2(M, N, M1, ETA, TOL, QR, C(K3), N1, IPIVOT, SING, * MMPNN) C IF (.NOT.SING) GO TO 110 IF (N1.GT.0) GO TO 100 IFAULT = 5 RETURN 100 IFAULT = 6 RETURN C C SEEK A SOLUTION (COEFFICIENTS AND RESIDUALS) FOR EACH OF THE L LEAST C SQUARES PROBLEMS WHOSE RIGHT-HAND SIDES ARE GIVEN IN THE ARRAY B. C 110 ITER = -ALOG10(ETA) DO 200 K=1,L C K-TH RIGHT-HAND SIDE. K0 = K4 - 1 DO 120 I=1,M K0 = K0 + 1 C(K0) = B(I,K) 120 CONTINUE C CALL SOLVE2(M, N, M1, A, C(K4), W, N1, IPIVOT, QR, C(K3), * ETA, FAIL, NUMIT, DIGITX, * C(K5), C(K6), C(K7), C(K8), C(K9), C(K10), C(K11), C(K12), * MM, MMPNN) C K0 = K5 - 1 DO 130 J=1,N K0 = K0 + 1 X(J,K) = C(K0) 130 CONTINUE IF (M1.EQ.0) GO TO 150 DO 140 I=1,M1 RES(I,K) = 0.0 140 CONTINUE 150 M1P1 = M1 + 1 IF (M1P1.GT.M) GO TO 170 K0 = K6 + M1 - 1 DO 160 I=M1P1,M K0 = K0 + 1 RES(I,K) = C(K0) 160 CONTINUE 170 CONTINUE C C FOR RIGHT-HAND SIDES WHERE CONVERGENCE OF A SOLUTION IS REPORTED, C A CHECK IS MADE FOR EVIDENCE OF SEVERE ILL-CONDITIONING. SUCH C EVIDENCE IS FURNISHED BY LARGE VALUES OF NUMIT (NUMBER OF ITERATIONS C BEFORE CONVERGENCE WAS OBTAINED) AND SMALL VALUES OF DIGITX C (ESTIMATE OF THE NUMBER OF CORRECT DIGITS IN THE INITIAL SOLUTION C OF THE COEFFICIENTS). IF NUMIT EXCEEDS -ALOG10(ETA) THEN IFAULT C IS SET TO 9. IF DIGITX IS LESS THAN 0.5 (HALF A DECIMAL DIGIT) C THEN IFAULT IS SET TO 10. C C(K) = FLOAT(NUMIT) IF (FAIL) C(K) = -C(K) K0 = K2 + K - 1 C(K0) = DIGITX IF (.NOT.FAIL) GO TO 180 C KSUM IS A TALLY OF SOLUTIONS WHICH FAILED TO CONVERGE. KSUM = KSUM + 1 IFAULT = 8 GO TO 200 180 IF (NUMIT.LE.ITER) GO TO 190 IFAULT = 9 190 IF (DIGITX.GE.0.5) GO TO 200 IFAULT = 10 200 CONTINUE IF (KSUM.LT.L) GO TO 210 IFAULT = 7 RETURN 210 IF (N1.LT.N) RETURN DO 230 I=1,N MPI = M + I DO 220 J=1,N QR(I,J) = QR(MPI,J) 220 CONTINUE QR(I,I) = 0.0 230 CONTINUE C C COMPUTE THE UNSCALED COVARIANCE MATRIX OF THE COEFFICIENTS. C CALL COVAR(N, M1, N1, IPIVOT, QR, C(K3), C(K9), MMPNN) IF (N.EQ.1) GO TO 260 DO 250 J=2,N JM1 = J - 1 DO 240 I=1,JM1 240 QR(I,J) = QR(J,I) 250 CONTINUE C C IN CERTAIN PROBLEMS, SOME DIAGONAL TERMS OF THE UNSCALED COVARIANCE C MATRIX ARE EQUAL TO ZERO OR TO SMALL POSITIVE NUMBERS. BECAUSE OF C ROUNDING ERRORS, COMPUTED VALUES FOR THESE TERMS MAY BE SMALL C NEGATIVE NUMBERS. IFAULT IS SET TO 11 IF THIS OCCURS. C 260 DO 270 J=1,N IF (QR(J,J).LT.0.0) GO TO 280 270 CONTINUE RETURN 280 IF (IFAULT.NE.0) GO TO 290 IFAULT = 11 RETURN 290 IFAULT = 12 RETURN END C SUBROUTINE DECOM2(...) C SUBROUTINE DECOM2 USES A MODIFIED GRAM-SCHMIDT ALGORITHM WITH C PIVOTING TO OBTAIN AN ORTHOGONAL DECOMPOSITION OF THE INPUT MATRIX C GIVEN IN QR. C THE INPUT PARAMETER TOL (EQUAL EITHER TO ZERO OR TO A POSITIVE C NUMBER) IS USED IN DETERMINING THE RANK OF MATRIX QR. C NOTE -- C (1) IF TOL EQUALS ZERO, THE TOLERANCE USED AT STATEMENT DC2 1180 C WILL BE BASED ON MACHINE PRECISION. C UNDER THIS APPROACH, THE TOLERANCE (TOL2) IS SET EQUAL TO C (FLOAT(N)*ETA)**2*D(M1+1) AT STATEMENT DC2 1170. C IF DESIRED, THE USER CAN OBTAIN A MORE CONSERVATIVE C TOLERANCE BY REPLACING N IN THIS STATEMENT BY A LARGER C QUANTITY. C (2) IF TOL IS GREATER THAN ZERO, TOL2 (WHICH IS SET EQUAL TO C TOL) WILL BE USED AT STATEMENT DC2 1180 AS AN ABSOLUTE C TOLERANCE FOR COMPARISON WITH DIAGONAL ELEMENTS OF THE C TRIANGULAR MATRIX OBTAINED IN THE DECOMPOSITION. UNDER THIS C APPROACH, THE VALUE OF TOL CAN BE BASED ON KNOWLEDGE C CONCERNING THE ACCURACY OF THE DATA. C ON EXIT, THE ARRAYS QR, D AND IPIVOT CONTAIN THE RESULTS OF THE C DECOMPOSITION WHICH ARE NEEDED FOR OBTAINING AN INITIAL SOLUTION C AND FOR ITERATIVE REFINEMENT. C ON EXIT, N1 IS THE COMPUTED RANK OF THE INPUT MATRIX QR. C ON EXIT, SING IS SET EQUAL TO .TRUE. WHENEVER C (1) N1 = 0 (I.E., INPUT MATRIX QR EQUALS ZERO OR MATRIX OF C CONSTRAINTS EQUALS ZERO), OR C (2) N1 IS LESS THAN M1 (I.E., THE M1 BY N MATRIX OF LINEAR C CONSTRAINTS IS SINGULAR). C OTHERWISE, ON EXIT FROM DECOM2, SING = .FALSE. C ON EXIT, THE VECTOR IPIVOT RECORDS THE ORDER IN WHICH THE COLUMNS C OF QR WERE SELECTED BY THE PIVOTING SCHEME IN THE COURSE OF THE C ORTHOGONAL DECOMPOSITION. SUBROUTINE DECOM2(M, N, M1, ETA, TOL, QR, D, N1, IPIVOT, SING, * MMPNN) INTEGER IPIVOT(N) REAL C, D(*), DM, DS, ETA, QR(MMPNN,N), RSJ, TOL, TOL2 DOUBLE PRECISION SUM LOGICAL FINIS, FSUM, SING N1 = 0 SING = .TRUE. FSUM = .TRUE. MV = 1 MH = M1 MS = M MP1 = M + 1 FINIS = .FALSE. IF (TOL.GT.0.0) TOL2 = TOL DO 10 J=1,N D(J) = 0.0 IPIVOT(J) = J 10 CONTINUE C STEP NUMBER NS OF THE DECOMPOSITION. DO 350 NS=1,N K = M + NS IF (NS.EQ.M1+1) GO TO 20 GO TO 30 20 IF (M1.EQ.M) GO TO 200 MV = M1 + 1 MH = M FSUM = .TRUE. 30 IF (.NOT.FINIS) GO TO 40 GO TO 150 C PIVOT SEARCH. 40 DS = 0.0 NP = NS DO 90 J=NS,N IF (FSUM) GO TO 50 GO TO 70 50 SUM = 0.0 DO 60 L=MV,MH SUM = SUM + DBLE(QR(L,J))*DBLE(QR(L,J)) 60 CONTINUE D(J) = SUM 70 IF (DS.LT.D(J)) GO TO 80 GO TO 90 80 DS = D(J) NP = J 90 CONTINUE IF (FSUM) DM = DS IF (DS.LT.ETA*DM) GO TO 100 FSUM = .FALSE. GO TO 110 100 FSUM = .TRUE. 110 IF (FSUM) GO TO 40 IF (NP.NE.NS) GO TO 120 GO TO 140 C COLUMN INTERCHANGE. 120 IK = IPIVOT(NP) IPIVOT(NP) = IPIVOT(NS) IPIVOT(NS) = IK D(NP) = D(NS) KM1 = K - 1 DO 130 L=1,KM1 C = QR(L,NP) QR(L,NP) = QR(L,NS) QR(L,NS) = C 130 CONTINUE C END COLUMN INTERCHANGE. C END PIVOT SEARCH. C RETURN HERE IF N1 = 0. EITHER INPUT MATRIX QR EQUALS ZERO OR C MATRIX OF CONSTRAINTS EQUALS ZERO. 140 IF (NS.EQ.1 .AND. DS.EQ.0.0) RETURN GO TO 160 150 MS = K - 1 MH = K - 1 160 IF (FINIS) GO TO 170 C = 0.0 GO TO 180 170 C = 1.0 180 SUM = DBLE(C) DO 190 L=MV,MH SUM = SUM + DBLE(QR(L,NS))*DBLE(QR(L,NS)) 190 CONTINUE D(NS) = SUM DS = D(NS) IF (TOL.EQ.0.0) TOL2 = (FLOAT(N)*ETA)**2*D(M1+1) IF (.NOT.FINIS .AND. NS.GT.M1 .AND. DS.LE.TOL2) GO TO 200 GO TO 290 200 FINIS = .TRUE. MV = M + 1 DO 280 NP=NS,N IF (1.GT.M1) GO TO 250 DO 210 L=1,M1 QR(L,NP) = 0.0 210 CONTINUE DO 240 J=1,M1 SUM = 0.0 DO 220 L=1,M SUM = SUM + DBLE(QR(L,J))*DBLE(QR(L,NP)) 220 CONTINUE C = SUM C = C/D(J) DO 230 L=1,M1 QR(L,NP) = QR(L,NP) - C*QR(L,J) 230 CONTINUE 240 CONTINUE 250 MPN1 = M + N1 DO 270 JJ=MP1,MPN1 J = (M + 1) + (M + N1) - JJ SUM = 0.0 DO 260 L=J,MPN1 LMM = L - M SUM = SUM + DBLE(QR(J,LMM))*DBLE(QR(L,NP)) 260 CONTINUE QR(J,NP) = -SUM 270 CONTINUE 280 CONTINUE GO TO 150 C RETURN HERE IF MATRIX OF CONSTRAINTS IS FOUND TO BE SINGULAR. 290 IF (DS.EQ.0.0) RETURN QR(K,NS) = -1.0 NSP1 = NS + 1 IF (NSP1.GT.N) GO TO 340 C BEGIN ORTHOGONALIZATION. DO 330 J=NSP1,N SUM = 0.0 DO 300 L=MV,MH SUM = SUM + DBLE(QR(L,J))*DBLE(QR(L,NS)) 300 CONTINUE RSJ = SUM RSJ = RSJ/DS QR(K,J) = RSJ DO 310 L=1,MS QR(L,J) = QR(L,J) - RSJ*QR(L,NS) 310 CONTINUE IF (.NOT.FINIS) GO TO 320 GO TO 330 320 D(J) = D(J) - DS*RSJ*RSJ 330 CONTINUE C END ORTHOGONALIZATION. 340 IF (.NOT.FINIS) N1 = N1 + 1 350 CONTINUE C END STEP NUMBER NS. SING = .FALSE. C NORMAL RETURN. RETURN END C SUBROUTINE SOLVE2(...) C SUBROUTINE SOLVE2 USES THE ORTHOGONAL DECOMPOSITION STORED IN QR, D C AND IPIVOT TO COMPUTE THE SOLUTION (COEFFICIENTS AND RESIDUALS) C TO THE LEAST SQUARES PROBLEM WHOSE RIGHT-HAND SIDE IS GIVEN IN B. C IN THE EVENT THAT N1 (THE COMPUTED RANK OF MATRIX H) IS LESS THAN N C (THE NUMBER OF UNKNOWN COEFFICIENTS), A UNIQUE SOLUTION VECTOR HAVING C N ELEMENTS CAN BE OBTAINED BY IMPOSING THE CONDITION THAT THE C SOLUTION BE OF MINIMAL EUCLIDEAN NORM. SUCH A SOLUTION IS SOUGHT IN C THE CASE OF UNDERDETERMINED OR RANK-DEFICIENT PROBLEMS. C IN NORMAL EXITS, THE SOLUTION IS CONTAINED IN THE VECTOR X C (COEFFICIENTS) AND THE VECTOR RES (RESIDUALS). C ITERATIVE REFINEMENT IS USED TO IMPROVE THE ACCURACY OF THE INITIAL C SOLUTION. C ON EXIT, FAIL IS SET EQUAL TO .TRUE. IF THE SOLUTION FAILS TO C IMPROVE SUFFICIENTLY. OTHERWISE, FAIL = .FALSE. INFORMATION ON THE C BEHAVIOR OF THE ITERATIVE REFINEMENT PROCEDURE IS GIVEN BY NUMIT AND C DIGITX. NUMIT IS THE NUMBER OF ITERATIONS CARRIED OUT IN ATTEMPTING C TO OBTAIN A SOLUTION. DIGITX IS AN ESTIMATE OF THE NUMBER OF C CORRECT DIGITS IN THE INITIAL SOLUTION OF THE COEFFICIENTS. C THIS SUBROUTINE CALLS SUBROUTINE SOLVE3. C C ********* CONVERSION OF THIS SUBROUTINE TO DOUBLE PRECISION ********* C * IF THE PROGRAM IS CONVERTED SO THAT ALL CALCULATIONS ARE DONE IN * C * DOUBLE PRECISION ARITHMETIC, THE ITERATIVE REFINEMENT PRESENTLY * C * INCLUDED IN SOLVE2 SHOULD BE OMITTED, SINCE THE SUCCESS OF THIS * C * PROCEDURE DEPENDS ON COMPUTING INNER PRODUCTS IN GREATER * C * PRECISION THAN OTHER CALCULATIONS. * C * SEE COMMENTS IN SUBROUTINE L2SLV REGARDING CONVERSION TO DOUBLE * C * PRECISION. IN ADDITION, THE FOLLOWING COMMENTS INDICATE HOW TO * C * OMIT THE ITERATIVE REFINEMENT FROM THIS SUBROUTINE. STATEMENT * C * NUMBERS GIVEN HERE REFER TO THOSE IN THE RIGHT-HAND MARGIN. * C * * C * 1. IN STATEMENT SV2 470 CHANGE REAL TO DOUBLE PRECISION. * C * 2. REPLACE STATEMENT SV2 880 BY A STATEMENT READING * C * 30 DO 50 I=1,M * C * 3. REPLACE STATEMENTS SV2 1310-1400 BY A STATEMENT READING * C * RETURN * C * 4. OMIT STATEMENTS SV2 120-190, 440, 490-500, 520-550, 650, * C * 750-850, 1650-1830 AND 1850-1910. * C * * C ********************************************************************* C SUBROUTINE SOLVE2(M, N, M1, A, B, W, N1, IPIVOT, QR, D, * ETA, FAIL, NUMIT, DIGITX, * X, RES, WRES, Y1, Y2, Y, F, G, MM, MMPNN) INTEGER IPIVOT(N) REAL A(MM,N), B(*), C, D(*), F(*), G(*), * QR(MMPNN,N), RES(*), W(M), WRES(*), X(*), Y(*), Y1(*), Y2(*) REAL DIGITX, DXNORM, ETA, ETA2, RDR1, RDR2, RDX1, RDX2, RNR, * RNX, XNORM DOUBLE PRECISION SUM LOGICAL FAIL NUMIT = 0 KZ = 0 ETA2 = ETA*ETA MP1 = M + 1 MPN = M + N N1P1 = N1 + 1 DO 10 I=1,M F(I) = B(I)*W(I) G(I) = 0.0 WRES(I) = 0.0 RES(I) = 0.0 Y1(I) = 0.0 IF (W(I).EQ.0.0) KZ = KZ + 1 10 CONTINUE DO 20 NS=1,N J = M + NS F(J) = 0.0 G(J) = 0.0 X(NS) = 0.0 Y2(NS) = 0.0 20 CONTINUE K = 0 RDX2 = 0.0 RDR2 = 0.0 C BEGIN K-TH ITERATION STEP. 30 IF (K.LT.2) GO TO 40 IF (((64.*RDX2.LT.RDX1) .AND. (RDX2.GT.ETA2*RNX)) .OR. * ((64.*RDR2.LT.RDR1) .AND. (RDR2.GT.ETA2*RNR))) GO TO 40 GO TO 270 40 RDX1 = RDX2 RDR1 = RDR2 RDX2 = 0.0 RDR2 = 0.0 IF (K.EQ.0) GO TO 160 C NEW RESIDUALS. DO 50 I=1,M WRES(I) = WRES(I) + F(I)*W(I) IF (W(I).EQ.0.0) GO TO 50 RES(I) = RES(I) + F(I)/W(I) Y1(I) = Y1(I) + G(I) 50 CONTINUE DO 100 NS=1,N J = M + NS NP = IPIVOT(NS) X(NP) = X(NP) + F(J) Y2(NP) = Y2(NP) + G(J) SUM = -DBLE(X(NP)) DO 60 L=1,M SUM = SUM + DBLE(A(L,NP))*DBLE(Y1(L)) 60 CONTINUE G(J) = -SUM IF (NS.GT.N1) GO TO 70 GO TO 80 70 F(J) = 0.0 GO TO 100 80 SUM = 0.0 DO 90 L=1,M SUM = SUM + DBLE(A(L,NP))*DBLE(WRES(L)) 90 CONTINUE F(J) = -SUM 100 CONTINUE DO 130 I=1,M SUM = 0.0 IF (I.GT.M1) SUM = DBLE(RES(I)) DO 110 L=1,N SUM = SUM + DBLE(A(I,L))*DBLE(X(L)) 110 CONTINUE SUM = SUM - DBLE(B(I)) F(I) = -SUM F(I) = F(I)*W(I) IF (W(I).EQ.0.0) RES(I) = DBLE(RES(I)) - SUM SUM = 0.0 IF (I.GT.M1) SUM = DBLE(Y1(I)) DO 120 L=1,N SUM = SUM + DBLE(A(I,L))*DBLE(Y2(L)) 120 CONTINUE G(I) = -SUM 130 CONTINUE IF (N1P1.GT.N) GO TO 160 DO 150 I=N1P1,N NS = N + N1P1 - I J = M + NS SUM = 0.0 DO 140 L=1,J SUM = SUM + DBLE(QR(L,NS))*DBLE(G(L)) 140 CONTINUE G(J) = SUM 150 CONTINUE C END NEW RESIDUALS. C 160 CALL SOLVE3(F, M1, M, N1, QR, D, Y, MMPNN) C IF (N1P1.GT.N) GO TO 200 DO 190 NS=N1P1,N J = M + NS SUM = DBLE(G(J)) DO 170 L=MP1,J SUM = SUM + DBLE(QR(L,NS))*DBLE(F(L)) 170 CONTINUE C = SUM C = C/D(NS) DO 180 I=1,J F(I) = F(I) - C*QR(I,NS) 180 CONTINUE 190 CONTINUE 200 DO 210 J=MP1,MPN G(J) = 0.0 IF (J.LE.M+N1) G(J) = G(J) + F(J) 210 CONTINUE C CALL SOLVE3(G, M1, M, N1, QR, D, Y, MMPNN) C DO 220 I=1,M RDR2 = RDR2 + F(I)*F(I) 220 CONTINUE DO 230 I=MP1,MPN RDX2 = RDX2 + F(I)*F(I) 230 CONTINUE IF (K.NE.0) GO TO 240 RNR = RDR2 RNX = RDX2 240 IF (K.NE.1) GO TO 260 XNORM = SQRT(RNX) DXNORM = SQRT(RDX2) IF (XNORM.NE.0.0) GO TO 250 DIGITX = -ALOG10(ETA) GO TO 260 250 DIGITX = -ALOG10(AMAX1(DXNORM/XNORM,ETA)) C END K-TH ITERATION STEP. 260 NUMIT = K K = K + 1 GO TO 30 270 IF ((M1+KZ.EQ.M) .AND. (RDX2.GT.4.*ETA2*RNX)) GO TO 280 IF ((RDR2.GT.4.*ETA2*RNR) .AND. * (RDX2.GT.4.*ETA2*RNX)) GO TO 280 FAIL = .FALSE. RETURN 280 FAIL = .TRUE. RETURN END SUBROUTINE SOLVE3(F, M1, M, N1, QR, D, Y, MMPNN) C SUBROUTINE SOLVE3 IS CALLED ONLY BY SUBROUTINE SOLVE2. C THIS SUBROUTINE CALCULATES NEW VALUES OF F. REAL C, D(*), F(*), QR(MMPNN,N1), Y(*) DOUBLE PRECISION SUM MV = 1 MH = M1 DO 100 NS=1,N1 J = M + NS IF (NS.EQ.M1+1) GO TO 10 GO TO 20 10 MV = M1 + 1 MH = M 20 NSM1 = NS - 1 SUM = -DBLE(F(J)) IF (NS.EQ.1) GO TO 40 DO 30 L=1,NSM1 MPL = M + L SUM = SUM + DBLE(QR(MPL,NS))*DBLE(Y(L)) 30 CONTINUE 40 Y(NS) = -SUM IF (NS.GT.M1) GO TO 50 GO TO 60 50 C = -Y(NS) GO TO 70 60 C = 0.0 70 SUM = DBLE(C) DO 80 L=MV,MH SUM = SUM + DBLE(QR(L,NS))*DBLE(F(L)) 80 CONTINUE C = SUM C = C/D(NS) F(J) = C DO 90 L=MV,M F(L) = F(L) - C*QR(L,NS) 90 CONTINUE 100 CONTINUE IF (1.GT.M1) GO TO 150 DO 110 L=1,M1 F(L) = 0.0 110 CONTINUE DO 140 NS=1,M1 SUM = -DBLE(Y(NS)) DO 120 L=1,M SUM = SUM + DBLE(QR(L,NS))*DBLE(F(L)) 120 CONTINUE C = SUM C = C/D(NS) DO 130 L=1,M1 F(L) = F(L) - C*QR(L,NS) 130 CONTINUE 140 CONTINUE 150 DO 170 NS=1,N1 J = M + N1 + 1 - NS MPN1 = M + N1 SUM = 0.0 DO 160 L=J,MPN1 LMM = L - M SUM = SUM + DBLE(QR(J,LMM))*DBLE(F(L)) 160 CONTINUE F(J) = -SUM 170 CONTINUE RETURN END SUBROUTINE COVAR(N, M1, N1, IPIVOT, C, D, Z, NN) C SUBROUTINE COVAR USES RESULTS FROM THE ORTHOGONAL DECOMPOSITION C STORED IN C, D AND IPIVOT TO COMPUTE THE UNSCALED COVARIANCE MATRIX C OF THE LEAST SQUARES COEFFICIENTS. C ON ENTRY, THE FIRST N ROWS AND THE FIRST N COLUMNS OF C CONTAIN THE C UPPER TRIANGULAR MATRIX OBTAINED FROM THE DECOMPOSITION. THIS INPUT C MATRIX IS DESTROYED IN SUBSEQUENT CALCULATIONS. C ON EXIT, THE LOWER TRIANGULAR PORTION OF THE SYMMETRIC UNSCALED C COVARIANCE MATRIX IS CONTAINED IN C C(1,1) C C(2,1) C(2,2) C . . . C C(N,1) C(N,2) ... C(N,N) C IF N1 IS LESS THAN N, ONE OR MORE COLUMNS OF THE MATRIX C H = (SQRT(W))*A WERE REJECTED AS BEING LINEARLY DEPENDENT. WHENEVER C THE K-TH COLUMN OF H WAS SO REJECTED, C(I,J) IS SET EQUAL TO ZERO, C FOR I = K OR J = K, I.GE.J. INTEGER IPIVOT(N) REAL C(NN,N), D(*), Z(*) DOUBLE PRECISION SUM L = N1 IF (L.GT.M1) C(L,L) = 1.0/D(L) IF (L.EQ.1) GO TO 60 10 J = L - 1 IF (J.GT.M1) C(J,J) = 1.0/D(J) DO 20 K=L,N1 Z(K) = C(J,K) 20 CONTINUE I = N1 DO 40 KA=J,N1 SUM = 0.0 IF (I.EQ.J) SUM = DBLE(C(I,J)) DO 30 K=L,N1 SUM = SUM - DBLE(Z(K))*DBLE(C(K,I)) 30 CONTINUE C(I,J) = SUM I = I - 1 40 CONTINUE DO 50 K=L,N1 C(J,K) = C(K,J) 50 CONTINUE L = L - 1 IF (L.GT.1) GO TO 10 60 IF (N1.EQ.N) GO TO 90 N1P1 = N1 + 1 DO 80 I=1,N DO 70 J=N1P1,N C(I,J) = 0.0 70 CONTINUE 80 CONTINUE C PERMUTE THE COLUMNS AND ROWS OF MATRIX C TO ACCOUNT FOR PIVOTING. 90 DO 120 I=1,N DO 100 J=1,N K = IPIVOT(J) Z(K) = C(I,J) 100 CONTINUE DO 110 J=1,N C(I,J) = Z(J) 110 CONTINUE 120 CONTINUE DO 150 I=1,N DO 130 J=1,N K = IPIVOT(J) Z(K) = C(J,I) 130 CONTINUE DO 140 J=I,N C(J,I) = Z(J) 140 CONTINUE 150 CONTINUE RETURN END SUBROUTINE SPLSQ(M,N,A,IA,JA,DAMP,U,X,ATOL,BTOL,CONLIM,ITNLIM, * ISTOP,ITN,ACOND,RNORM,XNORM,W) C INTEGER M,N,ITNLIM,ISTOP INTEGER IA(*),JA(*) REAL A(*),DAMP,U(M),X(N),ATOL,BTOL,CONLIM, * ACOND,RNORM,XNORM,W(*) C ------------------------------------------------------------------ C C SPLSQ FINDS A SOLUTION X TO THE FOLLOWING PROBLEMS ... C C 1. UNSYMMETRIC EQUATIONS -- SOLVE A*X = B C C 2. LINEAR LEAST SQUARES -- SOLVE A*X = B C IN THE LEAST-SQUARES SENSE C C 3. DAMPED LEAST SQUARES -- SOLVE ( A )*X = ( B ) C ( DAMP*I ) ( 0 ) C IN THE LEAST-SQUARES SENSE C C WHERE A IS A MATRIX WITH M ROWS AND N COLUMNS, B AN M-VECTOR, C AND DAMP A SCALAR. (ALL QUANTITIES ARE REAL.) THE MATRIX A IS C A SPARSE MATRIX STORED ROWWISE IN THE ARRAYS A,IA,JA. C C THE RHS VECTOR B IS INPUT VIA U, AND IS SUBSEQUENTLY OVERWRITTEN. C C C NOTE. SPLSQ USES AN ITERATIVE METHOD TO APPROXIMATE THE SOLUTION. C THE NUMBER OF ITERATIONS REQUIRED TO REACH A CERTAIN ACCURACY C DEPENDS STRONGLY ON THE SCALING OF THE PROBLEM. POOR SCALING OF C THE ROWS OR COLUMNS OF A SHOULD THEREFORE BE AVOIDED WHENEVER C POSSIBLE. C C FOR EXAMPLE, IN PROBLEM 1 THE SOLUTION IS UNALTERED BY C ROW-SCALING. IF A ROW OF A IS VERY SMALL OR LARGE COMPARED TO C THE OTHER ROWS OF A, THE CORRESPONDING ROW OF (A B) SHOULD BE C SCALED UP OR DOWN. C C IN PROBLEMS 1 AND 2, THE SOLUTION X IS EASILY RECOVERED C FOLLOWING COLUMN SCALING. IN THE ABSENCE OF BETTER INFORMATION, C THE NONZERO COLUMNS OF A SHOULD BE SCALED SO THAT THEY ALL HAVE C THE SAME EUCLIDEAN NORM (E.G. 1.0). C C IN PROBLEM 3, THERE IS NO FREEDOM TO RE-SCALE IF DAMP IS C NONZERO. HOWEVER, THE VALUE OF DAMP SHOULD BE ASSIGNED ONLY C AFTER ATTENTION HAS BEEN PAID TO THE SCALING OF A. C C THE PARAMETER DAMP IS INTENDED TO HELP REGULARIZE C ILL-CONDITIONED SYSTEMS, BY PREVENTING THE TRUE SOLUTION FROM C BEING VERY LARGE. ANOTHER AID TO REGULARIZATION IS PROVIDED BY C THE PARAMETER ACOND, WHICH MAY BE USED TO TERMINATE ITERATIONS C BEFORE THE COMPUTED SOLUTION BECOMES VERY LARGE. C C C NOTATION C -------- C C THE FOLLOWING QUANTITIES ARE USED IN DISCUSSING THE SUBROUTINE C PARAMETERS... C C ABAR = ( A ), BBAR = ( B ) C ( DAMP*I ) ( 0 ) C C R = B - A*X, RBAR = BBAR - ABAR*X C C RNORM = SQRT( NORM(R)**2 + DAMP**2 * NORM(X)**2 ) C = NORM( RBAR ) C C RELPR = THE SMALLEST FLOATING POINT NUMBER FOR WHICH C 1 + RELPR .GT. 1. C C SPLSQ MINIMIZES THE FUNCTION RNORM WITH RESPECT TO X. C C C PARAMETERS C ---------- C C M INPUT THE NUMBER OF ROWS IN A. C C N INPUT THE NUMBER OF COLUMNS IN A. C C A,IA,JA INPUT THE MATRIX A STORED ROWWISE IN SPARSE FORM. C C DAMP INPUT THE DAMPING PARAMETER FOR PROBLEM 3 ABOVE. C (DAMP SHOULD BE 0.0 FOR PROBLEMS 1 AND 2.) C IF THE SYSTEM A*X = B IS INCOMPATIBLE, VALUES C OF DAMP IN THE RANGE 0 TO SQRT(RELPR)*NORM(A) C WILL PROBABLY HAVE A NEGLIGIBLE EFFECT. C LARGER VALUES OF DAMP WILL TEND TO DECREASE C THE NORM OF X AND TO REDUCE THE NUMBER OF C ITERATIONS REQUIRED BY SPLSQ. C C THE WORK PER ITERATION AND THE STORAGE NEEDED C BY SPLSQ ARE THE SAME FOR ALL VALUES OF DAMP. C C U(M) INPUT THE RHS VECTOR B. BE AWARE THAT U IS C OVER-WRITTEN BY SPLSQ. C C X(N) OUTPUT RETURNS THE COMPUTED SOLUTION X. C C ATOL INPUT AN ESTIMATE OF THE RELATIVE ERROR IN THE DATA C DEFINING THE MATRIX A. FOR EXAMPLE, C IF A IS ACCURATE TO ABOUT 6 DIGITS, SET C ATOL = 1.0E-6 . C C BTOL INPUT AN ESTIMATE OF THE RELATIVE ERROR IN THE DATA C DEFINING THE RHS VECTOR B. FOR EXAMPLE, C IF B IS ACCURATE TO ABOUT 6 DIGITS, SET C BTOL = 1.0E-6 . C C CONLIM INPUT AN UPPER LIMIT ON COND(ABAR), THE APPARENT C CONDITION NUMBER OF THE MATRIX ABAR. C ITERATIONS WILL BE TERMINATED IF A COMPUTED C ESTIMATE OF COND(ABAR) EXCEEDS CONLIM. C THIS IS INTENDED TO PREVENT CERTAIN SMALL OR C ZERO SINGULAR VALUES OF A OR ABAR FROM C COMING INTO EFFECT AND CAUSING UNWANTED GROWTH C IN THE COMPUTED SOLUTION. C C CONLIM AND DAMP MAY BE USED SEPARATELY OR C TOGETHER TO REGULARIZE ILL-CONDITIONED SYSTEMS. C C NORMALLY, CONLIM SHOULD BE IN THE RANGE C 1000 TO 1/RELPR. C SUGGESTED VALUE -- C CONLIM = 1/(100*RELPR) FOR COMPATIBLE SYSTEMS, C CONLIM = 1/(10*SQRT(RELPR)) FOR LEAST SQUARES. C C NOTE. IF THE USER IS NOT CONCERNED ABOUT THE PARAMETERS C ATOL, BTOL, AND CONLIM, ANY OR ALL OF THEM MAY BE SET C TO ZERO. THE EFFECT WILL BE THE SAME AS THE VALUES C RELPR, RELPR, AND 1/RELPR RESPECTIVELY. C C ITNLIM INPUT AN UPPER LIMIT ON THE NUMBER OF ITERATIONS. C SUGGESTED VALUE -- C ITNLIM = N/2 FOR WELL CONDITIONED SYSTEMS, C ITNLIM = 4*N OTHERWISE. C C ISTOP OUTPUT AN INTEGER GIVING THE REASON FOR TERMINATION... C C 0 X = 0 IS THE EXACT SOLUTION. C NO ITERATIONS WERE PERFORMED. C C 1 THE EQUATIONS A*X = B ARE PROBABLY C COMPATIBLE. NORM(A*X - B) IS SUFFICIENTLY C SMALL, GIVEN THE VALUES OF ATOL AND BTOL. C C 2 THE SYSTEM A*X = B IS PROBABLY NOT C COMPATIBLE. A LEAST-SQUARES SOLUTION HAS C BEEN OBTAINED WHICH IS SUFFICIENTLY ACCURATE, C GIVEN THE VALUE OF ATOL. C C 3 AN ESTIMATE OF COND(ABAR) HAS EXCEEDED C CONLIM. THE SYSTEM A*X = B APPEARS TO BE C ILL-CONDITIONED. C C 4 THE EQUATIONS A*X = B ARE PROBABLY C COMPATIBLE. NORM(A*X - B) IS AS SMALL AS C SEEMS REASONABLE ON THIS MACHINE. C C 5 THE SYSTEM A*X = B IS PROBABLY NOT C COMPATIBLE. A LEAST-SQUARES SOLUTION HAS C BEEN OBTAINED WHICH IS AS ACCURATE AS SEEMS C REASONABLE ON THIS MACHINE. C C 6 COND(ABAR) SEEMS TO BE SO LARGE THAT THERE IS C NOT MUCH POINT IN DOING FURTHER ITERATIONS, C GIVEN THE PRECISION OF THIS MACHINE. C C 7 THE ITERATION LIMIT ITNLIM WAS REACHED. C C C ITN OUTPUT THE NUMBER OF ITERATIONS THAT WERE PERFORMED. C C ACOND OUTPUT AN ESTIMATE OF COND(ABAR), THE CONDITION C NUMBER OF ABAR. C C RNORM OUTPUT AN ESTIMATE OF THE FINAL VALUE OF NORM(RBAR), C THE FUNCTION BEING MINIMIZED (SEE NOTATION C ABOVE). THIS WILL BE SMALL IF A*X = B HAS C A SOLUTION. C C XNORM OUTPUT AN ESTIMATE OF THE NORM OF THE FINAL C SOLUTION VECTOR X. C C W(2*N) WORKSPACE C C ANORM LOCAL AN ESTIMATE OF THE FROBENIUS NORM OF ABAR. C THIS IS THE SQUARE ROOT OF THE SUM OF SQUARES C OF THE ELEMENTS OF ABAR. C IF DAMP IS SMALL AND IF THE COLUMNS OF A C HAVE ALL BEEN SCALED TO HAVE LENGTH 1.0, C ANORM SHOULD INCREASE TO ROUGHLY SQRT(N). C C ARNORM LOCAL AN ESTIMATE OF THE FINAL VALUE OF C NORM( ABAR(TRANSPOSE)*RBAR ), THE NORM OF C THE RESIDUAL FOR THE USUAL NORMAL EQUATIONS. C THIS SHOULD BE SMALL IN ALL CASES. (ARNORM C WILL OFTEN BE SMALLER THAN THE TRUE VALUE C COMPUTED FROM THE OUTPUT VECTOR X.) C C C SUBROUTINES AND FUNCTIONS USED C ------------------------------ C C NORMLZ,MVPRD1,MTPRD1 C BLAS SCOPY,SNRM2,SSCAL (SEE LAWSON ET AL. BELOW) C (SNRM2 IS USED ONLY IN NORMLZ) C FORTRAN ABS,SQRT C C C REFERENCES C ---------- C C PAIGE, C.C. AND SAUNDERS, M.A. LSQR, AN ALGORITHM FOR SPARSE C LINEAR EQUATIONS AND SPARSE LEAST SQUARES. C ACM TRANSACTIONS ON MATHEMATICAL SOFTWARE 8, 1 (MARCH 1982). C C LAWSON, C.L., HANSON, R.J., KINCAID, D.R. AND KROGH, F.T. C BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE. C ACM TRANSACTIONS ON MATHEMATICAL SOFTWARE 5, 3 (SEPT 1979), C 308-323 AND 324-325. C C ------------------------------------------------------------------ C C LOCAL VARIABLES C INTEGER I,ITN,NCONV,NSTOP REAL ALFA,ANORM,ARNORM,BBNORM,BETA,BNORM, 1 CS,CS1,CS2,CTOL,DAMPSQ,DDNORM,DELTA, 2 GAMMA,GAMBAR,ONE,PHI,PHIBAR,PSI, 3 RES1,RES2,RHO,RHOBAR,RHBAR1,RHBAR2,RHS,RTOL, 4 SN,SN1,SN2,T,TAU,TEST1,TEST2,TEST3, 5 THETA,T1,T2,T3,XXNORM,Z,ZBAR,ZERO C C C INITIALIZE. C ZERO = 0.0 ONE = 1.0 CTOL = ZERO IF (CONLIM .GT. ZERO) CTOL = ONE/CONLIM DAMPSQ = DAMP**2 ANORM = ZERO ACOND = ZERO BBNORM = ZERO DDNORM = ZERO RES2 = ZERO XNORM = ZERO XXNORM = ZERO CS2 = -ONE SN2 = ZERO Z = ZERO ITN = 0 ISTOP = 0 NSTOP = 0 C DO 10 I = 1, N W(I) = ZERO X(I) = ZERO 10 CONTINUE C C SET UP THE FIRST VECTORS FOR THE BIDIAGONALIZATION. C THESE SATISFY BETA*U = B, ALFA*W = A(TRANSPOSE)*U. C CALL NORMLZ(M,U,BETA) CALL MTPRD1(M,N,A,IA,JA,U,W) CALL NORMLZ(N,W,ALFA) CALL SCOPY (N,W,1,W(N+1),1) C RHOBAR = ALFA PHIBAR = BETA BNORM = BETA RNORM = BETA ARNORM = ALFA*BETA IF (ARNORM .LE. ZERO) GO TO 800 C C ------------------------------------------------------------------ C MAIN ITERATION LOOP. C ------------------------------------------------------------------ 100 ITN = ITN + 1 C C PERFORM THE NEXT STEP OF THE BIDIAGONALIZATION TO OBTAIN THE C NEXT BETA, U, ALFA, W. THESE SATISFY THE RELATIONS C BETA*U = A*W - ALFA*U, C ALFA*W = A(TRANSPOSE)*U - BETA*W. C CALL SSCAL (M,(-ALFA),U,1) CALL MVPRD1(M,N,A,IA,JA,W,U) CALL NORMLZ(M,U,BETA) BBNORM = BBNORM + ALFA**2 + BETA**2 + DAMPSQ CALL SSCAL (N,(-BETA),W,1) CALL MTPRD1(M,N,A,IA,JA,U,W) CALL NORMLZ(N,W,ALFA) C C C USE A PLANE ROTATION TO ELIMINATE THE DAMPING PARAMETER. C THIS ALTERS THE DIAGONAL (RHOBAR) OF THE LOWER-BIDIAGONAL MATRIX. C RHBAR2 = RHOBAR**2 + DAMPSQ RHBAR1 = SQRT(RHBAR2) CS1 = RHOBAR/RHBAR1 SN1 = DAMP/RHBAR1 PSI = SN1*PHIBAR PHIBAR = CS1*PHIBAR C C C USE A PLANE ROTATION TO ELIMINATE THE SUBDIAGONAL ELEMENT (BETA) C OF THE LOWER-BIDIAGONAL MATRIX, GIVING AN UPPER-BIDIAGONAL MATRIX. C RHO = SQRT(RHBAR2 + BETA**2) CS = RHBAR1/RHO SN = BETA/RHO THETA = SN*ALFA RHOBAR = -CS*ALFA PHI = CS*PHIBAR PHIBAR = SN*PHIBAR TAU = SN*PHI C C C UPDATE X AND W(N+1),...,W(2*N) C T1 = PHI/RHO T2 = -THETA/RHO T3 = ONE/RHO C DO 200 I = 1, N NPI = N + I T = W(NPI) X(I) = T1*T + X(I) W(NPI)= T2*T + W(I) T =(T3*T)**2 DDNORM= T + DDNORM 200 CONTINUE C C C USE A PLANE ROTATION ON THE RIGHT TO ELIMINATE THE C SUPER-DIAGONAL ELEMENT (THETA) OF THE UPPER-BIDIAGONAL MATRIX. C THEN USE THE RESULT TO ESTIMATE NORM(X). C DELTA = SN2*RHO GAMBAR = -CS2*RHO RHS = PHI - DELTA*Z ZBAR = RHS/GAMBAR XNORM = SQRT(XXNORM + ZBAR**2) GAMMA = SQRT(GAMBAR**2 + THETA**2) CS2 = GAMBAR/GAMMA SN2 = THETA/GAMMA Z = RHS/GAMMA XXNORM = XXNORM + Z**2 C C C TEST FOR CONVERGENCE. C FIRST, ESTIMATE THE NORM AND CONDITION OF THE MATRIX ABAR, C AND THE NORMS OF RBAR AND ABAR(TRANSPOSE)*RBAR. C ANORM = SQRT(BBNORM) ACOND = ANORM*SQRT(DDNORM) RES1 = PHIBAR**2 RES2 = RES2 + PSI**2 RNORM = SQRT(RES1 + RES2) ARNORM = ALFA*ABS(TAU) C C NOW USE THESE NORMS TO ESTIMATE CERTAIN OTHER QUANTITIES, C SOME OF WHICH WILL BE SMALL NEAR A SOLUTION. C TEST1 = RNORM/BNORM TEST2 = ARNORM/(ANORM*RNORM) TEST3 = ONE/ACOND T1 = TEST1/(ONE + ANORM*XNORM/BNORM) RTOL = BTOL + ATOL*ANORM*XNORM/BNORM C C THE FOLLOWING TESTS GUARD AGAINST EXTREMELY SMALL VALUES OF C ATOL, BTOL, OR CTOL. (THE USER MAY HAVE SET ANY OR ALL OF C THE PARAMETERS ATOL, BTOL, CONLIM TO ZERO.) C THE EFFECT IS EQUIVALENT TO THE NORMAL TESTS USING C ATOL = RELPR, BTOL = RELPR, CONLIM = 1/RELPR. C T3 = ONE + TEST3 T2 = ONE + TEST2 T1 = ONE + T1 IF (ITN .GE. ITNLIM) ISTOP = 7 IF (T3 .LE. ONE ) ISTOP = 6 IF (T2 .LE. ONE ) ISTOP = 5 IF (T1 .LE. ONE ) ISTOP = 4 C C ALLOW FOR TOLERANCES SET BY THE USER. C IF (TEST3 .LE. CTOL) ISTOP = 3 IF (TEST2 .LE. ATOL) ISTOP = 2 IF (TEST1 .LE. RTOL) ISTOP = 1 C C STOP IF APPROPRIATE. C THE CONVERGENCE CRITERIA ARE REQUIRED TO BE MET ON NCONV C CONSECUTIVE ITERATIONS, WHERE NCONV IS SET BELOW. C SUGGESTED VALUE -- NCONV = 1, 2 OR 3. C IF (ISTOP .EQ. 0) NSTOP = 0 IF (ISTOP .EQ. 0) GO TO 100 NCONV = 1 NSTOP = NSTOP + 1 IF (NSTOP .LT. NCONV .AND. ITN .LT. ITNLIM) ISTOP = 0 IF (ISTOP .EQ. 0) GO TO 100 C ------------------------------------------------------------------ C END OF ITERATION LOOP. C ------------------------------------------------------------------ C 800 RETURN END SUBROUTINE NORMLZ(N,X,BETA) INTEGER N REAL X(N),BETA C C NORMLZ COMPUTES THE EUCLIDEAN NORM OF X AND RETURNS THE C VALUE IN BETA. IF X IS NONZERO, THEN X IS RESCALED SO C THAT NORM(X) = 1. C C FUNCTIONS AND SUBROUTINES C C BLAS SNRM2,SSCAL C REAL ONE,SNRM2,ZERO C DATA ZERO/0.0/, ONE/1.0/ C C BETA = SNRM2(N,X,1) IF (BETA .GT. ZERO) CALL SSCAL(N,(ONE/BETA),X,1) RETURN END SUBROUTINE STLSQ(M,N,TA,ITA,JTA,DAMP,U,X,ATOL,BTOL,CONLIM, * ITNLIM,ISTOP,ITN,ACOND,RNORM,XNORM,W) C INTEGER M,N,ITNLIM,ISTOP INTEGER ITA(*),JTA(*) REAL TA(*),DAMP,U(M),X(N),ATOL,BTOL,CONLIM, * ACOND,RNORM,XNORM,W(*) C ------------------------------------------------------------------ C C STLSQ FINDS A SOLUTION X TO THE FOLLOWING PROBLEMS ... C C 1. UNSYMMETRIC EQUATIONS -- SOLVE A*X = B C C 2. LINEAR LEAST SQUARES -- SOLVE A*X = B C IN THE LEAST-SQUARES SENSE C C 3. DAMPED LEAST SQUARES -- SOLVE ( A )*X = ( B ) C ( DAMP*I ) ( 0 ) C IN THE LEAST-SQUARES SENSE C C WHERE A IS A MATRIX WITH M ROWS AND N COLUMNS, B AN M-VECTOR, C AND DAMP A SCALAR. (ALL QUANTITIES ARE REAL.) THE MATRIX A IS C A SPARSE MATRIX WHOSE TRANSPOSE IS STORED ROWWISE IN THE ARRAYS C TA,ITA,JTA. C C THE RHS VECTOR B IS INPUT VIA U, AND IS SUBSEQUENTLY OVERWRITTEN. C C C NOTE. STLSQ USES AN ITERATIVE METHOD TO APPROXIMATE THE SOLUTION. C THE NUMBER OF ITERATIONS REQUIRED TO REACH A CERTAIN ACCURACY C DEPENDS STRONGLY ON THE SCALING OF THE PROBLEM. POOR SCALING OF C THE ROWS OR COLUMNS OF A SHOULD THEREFORE BE AVOIDED WHENEVER C POSSIBLE. C C FOR EXAMPLE, IN PROBLEM 1 THE SOLUTION IS UNALTERED BY C ROW-SCALING. IF A ROW OF A IS VERY SMALL OR LARGE COMPARED TO C THE OTHER ROWS OF A, THE CORRESPONDING ROW OF (A B) SHOULD BE C SCALED UP OR DOWN. C C IN PROBLEMS 1 AND 2, THE SOLUTION X IS EASILY RECOVERED C FOLLOWING COLUMN SCALING. IN THE ABSENCE OF BETTER INFORMATION, C THE NONZERO COLUMNS OF A SHOULD BE SCALED SO THAT THEY ALL HAVE C THE SAME EUCLIDEAN NORM (E.G. 1.0). C C IN PROBLEM 3, THERE IS NO FREEDOM TO RE-SCALE IF DAMP IS C NONZERO. HOWEVER, THE VALUE OF DAMP SHOULD BE ASSIGNED ONLY C AFTER ATTENTION HAS BEEN PAID TO THE SCALING OF A. C C THE PARAMETER DAMP IS INTENDED TO HELP REGULARIZE C ILL-CONDITIONED SYSTEMS, BY PREVENTING THE TRUE SOLUTION FROM C BEING VERY LARGE. ANOTHER AID TO REGULARIZATION IS PROVIDED BY C THE PARAMETER ACOND, WHICH MAY BE USED TO TERMINATE ITERATIONS C BEFORE THE COMPUTED SOLUTION BECOMES VERY LARGE. C C C NOTATION C -------- C C THE FOLLOWING QUANTITIES ARE USED IN DISCUSSING THE SUBROUTINE C PARAMETERS... C C ABAR = ( A ), BBAR = ( B ) C ( DAMP*I ) ( 0 ) C C R = B - A*X, RBAR = BBAR - ABAR*X C C RNORM = SQRT( NORM(R)**2 + DAMP**2 * NORM(X)**2 ) C = NORM( RBAR ) C C RELPR = THE SMALLEST FLOATING POINT NUMBER FOR WHICH C 1 + RELPR .GT. 1. C C STLSQ MINIMIZES THE FUNCTION RNORM WITH RESPECT TO X. C C C PARAMETERS C ---------- C C M INPUT THE NUMBER OF ROWS IN A. C C N INPUT THE NUMBER OF COLUMNS IN A. C C TA,ITA INPUT THE TRANSPOSE OF THE MATRIX A IS STORED C JTA ROWWISE IN SPARSE FORM. C C DAMP INPUT THE DAMPING PARAMETER FOR PROBLEM 3 ABOVE. C (DAMP SHOULD BE 0.0 FOR PROBLEMS 1 AND 2.) C IF THE SYSTEM A*X = B IS INCOMPATIBLE, VALUES C OF DAMP IN THE RANGE 0 TO SQRT(RELPR)*NORM(A) C WILL PROBABLY HAVE A NEGLIGIBLE EFFECT. C LARGER VALUES OF DAMP WILL TEND TO DECREASE C THE NORM OF X AND TO REDUCE THE NUMBER OF C ITERATIONS REQUIRED BY STLSQ. C C THE WORK PER ITERATION AND THE STORAGE NEEDED C BY STLSQ ARE THE SAME FOR ALL VALUES OF DAMP. C C U(M) INPUT THE RHS VECTOR B. BE AWARE THAT U IS C OVER-WRITTEN BY STLSQ. C C X(N) OUTPUT RETURNS THE COMPUTED SOLUTION X. C C ATOL INPUT AN ESTIMATE OF THE RELATIVE ERROR IN THE DATA C DEFINING THE MATRIX A. FOR EXAMPLE, C IF A IS ACCURATE TO ABOUT 6 DIGITS, SET C ATOL = 1.0E-6 . C C BTOL INPUT AN ESTIMATE OF THE RELATIVE ERROR IN THE DATA C DEFINING THE RHS VECTOR B. FOR EXAMPLE, C IF B IS ACCURATE TO ABOUT 6 DIGITS, SET C BTOL = 1.0E-6 . C C CONLIM INPUT AN UPPER LIMIT ON COND(ABAR), THE APPARENT C CONDITION NUMBER OF THE MATRIX ABAR. C ITERATIONS WILL BE TERMINATED IF A COMPUTED C ESTIMATE OF COND(ABAR) EXCEEDS CONLIM. C THIS IS INTENDED TO PREVENT CERTAIN SMALL OR C ZERO SINGULAR VALUES OF A OR ABAR FROM C COMING INTO EFFECT AND CAUSING UNWANTED GROWTH C IN THE COMPUTED SOLUTION. C C CONLIM AND DAMP MAY BE USED SEPARATELY OR C TOGETHER TO REGULARIZE ILL-CONDITIONED SYSTEMS. C C NORMALLY, CONLIM SHOULD BE IN THE RANGE C 1000 TO 1/RELPR. C SUGGESTED VALUE -- C CONLIM = 1/(100*RELPR) FOR COMPATIBLE SYSTEMS, C CONLIM = 1/(10*SQRT(RELPR)) FOR LEAST SQUARES. C C NOTE. IF THE USER IS NOT CONCERNED ABOUT THE PARAMETERS C ATOL, BTOL, AND CONLIM, ANY OR ALL OF THEM MAY BE SET C TO ZERO. THE EFFECT WILL BE THE SAME AS THE VALUES C RELPR, RELPR, AND 1/RELPR RESPECTIVELY. C C ITNLIM INPUT AN UPPER LIMIT ON THE NUMBER OF ITERATIONS. C SUGGESTED VALUE -- C ITNLIM = N/2 FOR WELL CONDITIONED SYSTEMS, C ITNLIM = 4*N OTHERWISE. C C ISTOP OUTPUT AN INTEGER GIVING THE REASON FOR TERMINATION... C C 0 X = 0 IS THE EXACT SOLUTION. C NO ITERATIONS WERE PERFORMED. C C 1 THE EQUATIONS A*X = B ARE PROBABLY C COMPATIBLE. NORM(A*X - B) IS SUFFICIENTLY C SMALL, GIVEN THE VALUES OF ATOL AND BTOL. C C 2 THE SYSTEM A*X = B IS PROBABLY NOT C COMPATIBLE. A LEAST-SQUARES SOLUTION HAS C BEEN OBTAINED WHICH IS SUFFICIENTLY ACCURATE, C GIVEN THE VALUE OF ATOL. C C 3 AN ESTIMATE OF COND(ABAR) HAS EXCEEDED C CONLIM. THE SYSTEM A*X = B APPEARS TO BE C ILL-CONDITIONED. C C 4 THE EQUATIONS A*X = B ARE PROBABLY C COMPATIBLE. NORM(A*X - B) IS AS SMALL AS C SEEMS REASONABLE ON THIS MACHINE. C C 5 THE SYSTEM A*X = B IS PROBABLY NOT C COMPATIBLE. A LEAST-SQUARES SOLUTION HAS C BEEN OBTAINED WHICH IS AS ACCURATE AS SEEMS C REASONABLE ON THIS MACHINE. C C 6 COND(ABAR) SEEMS TO BE SO LARGE THAT THERE IS C NOT MUCH POINT IN DOING FURTHER ITERATIONS, C GIVEN THE PRECISION OF THIS MACHINE. C C 7 THE ITERATION LIMIT ITNLIM WAS REACHED. C C C ITN OUTPUT THE NUMBER OF ITERATIONS THAT WERE PERFORMED. C C ACOND OUTPUT AN ESTIMATE OF COND(ABAR), THE CONDITION C NUMBER OF ABAR. C C RNORM OUTPUT AN ESTIMATE OF THE FINAL VALUE OF NORM(RBAR), C THE FUNCTION BEING MINIMIZED (SEE NOTATION C ABOVE). THIS WILL BE SMALL IF A*X = B HAS C A SOLUTION. C C XNORM OUTPUT AN ESTIMATE OF THE NORM OF THE FINAL C SOLUTION VECTOR X. C C W(2*N) WORKSPACE C C ANORM LOCAL AN ESTIMATE OF THE FROBENIUS NORM OF ABAR. C THIS IS THE SQUARE ROOT OF THE SUM OF SQUARES C OF THE ELEMENTS OF ABAR. C IF DAMP IS SMALL AND IF THE COLUMNS OF A C HAVE ALL BEEN SCALED TO HAVE LENGTH 1.0, C ANORM SHOULD INCREASE TO ROUGHLY SQRT(N). C C ARNORM LOCAL AN ESTIMATE OF THE FINAL VALUE OF C NORM( ABAR(TRANSPOSE)*RBAR ), THE NORM OF C THE RESIDUAL FOR THE USUAL NORMAL EQUATIONS. C THIS SHOULD BE SMALL IN ALL CASES. (ARNORM C WILL OFTEN BE SMALLER THAN THE TRUE VALUE C COMPUTED FROM THE OUTPUT VECTOR X.) C C C SUBROUTINES AND FUNCTIONS USED C ------------------------------ C C NORMLZ,MVPRD1,MTPRD1 C BLAS SCOPY,SNRM2,SSCAL (SEE LAWSON ET AL. BELOW) C (SNRM2 IS USED ONLY IN NORMLZ) C FORTRAN ABS,SQRT C C C REFERENCES C ---------- C C PAIGE, C.C. AND SAUNDERS, M.A. LSQR, AN ALGORITHM FOR SPARSE C LINEAR EQUATIONS AND SPARSE LEAST SQUARES. C ACM TRANSACTIONS ON MATHEMATICAL SOFTWARE 8, 1 (MARCH 1982). C C LAWSON, C.L., HANSON, R.J., KINCAID, D.R. AND KROGH, F.T. C BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE. C ACM TRANSACTIONS ON MATHEMATICAL SOFTWARE 5, 3 (SEPT 1979), C 308-323 AND 324-325. C C ------------------------------------------------------------------ C C LOCAL VARIABLES C INTEGER I,ITN,NCONV,NSTOP REAL ALFA,ANORM,ARNORM,BBNORM,BETA,BNORM, 1 CS,CS1,CS2,CTOL,DAMPSQ,DDNORM,DELTA, 2 GAMMA,GAMBAR,ONE,PHI,PHIBAR,PSI, 3 RES1,RES2,RHO,RHOBAR,RHBAR1,RHBAR2,RHS,RTOL, 4 SN,SN1,SN2,T,TAU,TEST1,TEST2,TEST3, 5 THETA,T1,T2,T3,XXNORM,Z,ZBAR,ZERO C C C INITIALIZE. C ZERO = 0.0 ONE = 1.0 CTOL = ZERO IF (CONLIM .GT. ZERO) CTOL = ONE/CONLIM DAMPSQ = DAMP**2 ANORM = ZERO ACOND = ZERO BBNORM = ZERO DDNORM = ZERO RES2 = ZERO XNORM = ZERO XXNORM = ZERO CS2 = -ONE SN2 = ZERO Z = ZERO ITN = 0 ISTOP = 0 NSTOP = 0 C DO 10 I = 1, N W(I) = ZERO X(I) = ZERO 10 CONTINUE C C SET UP THE FIRST VECTORS FOR THE BIDIAGONALIZATION. C THESE SATISFY BETA*U = B, ALFA*W = A(TRANSPOSE)*U. C CALL NORMLZ(M,U,BETA) CALL MVPRD1(N,M,TA,ITA,JTA,U,W) CALL NORMLZ(N,W,ALFA) CALL SCOPY (N,W,1,W(N+1),1) C RHOBAR = ALFA PHIBAR = BETA BNORM = BETA RNORM = BETA ARNORM = ALFA*BETA IF (ARNORM .LE. ZERO) GO TO 800 C C ------------------------------------------------------------------ C MAIN ITERATION LOOP. C ------------------------------------------------------------------ 100 ITN = ITN + 1 C C PERFORM THE NEXT STEP OF THE BIDIAGONALIZATION TO OBTAIN THE C NEXT BETA, U, ALFA, W. THESE SATISFY THE RELATIONS C BETA*U = A*W - ALFA*U, C ALFA*W = A(TRANSPOSE)*U - BETA*W. C CALL SSCAL (M,(-ALFA),U,1) CALL MTPRD1(N,M,TA,ITA,JTA,W,U) CALL NORMLZ(M,U,BETA) BBNORM = BBNORM + ALFA**2 + BETA**2 + DAMPSQ CALL SSCAL (N,(-BETA),W,1) CALL MVPRD1(N,M,TA,ITA,JTA,U,W) CALL NORMLZ(N,W,ALFA) C C C USE A PLANE ROTATION TO ELIMINATE THE DAMPING PARAMETER. C THIS ALTERS THE DIAGONAL (RHOBAR) OF THE LOWER-BIDIAGONAL MATRIX. C RHBAR2 = RHOBAR**2 + DAMPSQ RHBAR1 = SQRT(RHBAR2) CS1 = RHOBAR/RHBAR1 SN1 = DAMP/RHBAR1 PSI = SN1*PHIBAR PHIBAR = CS1*PHIBAR C C C USE A PLANE ROTATION TO ELIMINATE THE SUBDIAGONAL ELEMENT (BETA) C OF THE LOWER-BIDIAGONAL MATRIX, GIVING AN UPPER-BIDIAGONAL MATRIX. C RHO = SQRT(RHBAR2 + BETA**2) CS = RHBAR1/RHO SN = BETA/RHO THETA = SN*ALFA RHOBAR = -CS*ALFA PHI = CS*PHIBAR PHIBAR = SN*PHIBAR TAU = SN*PHI C C C UPDATE X AND W(N+1),...,W(2*N) C T1 = PHI/RHO T2 = -THETA/RHO T3 = ONE/RHO C DO 200 I = 1, N NPI = N + I T = W(NPI) X(I) = T1*T + X(I) W(NPI)= T2*T + W(I) T =(T3*T)**2 DDNORM= T + DDNORM 200 CONTINUE C C C USE A PLANE ROTATION ON THE RIGHT TO ELIMINATE THE C SUPER-DIAGONAL ELEMENT (THETA) OF THE UPPER-BIDIAGONAL MATRIX. C THEN USE THE RESULT TO ESTIMATE NORM(X). C DELTA = SN2*RHO GAMBAR = -CS2*RHO RHS = PHI - DELTA*Z ZBAR = RHS/GAMBAR XNORM = SQRT(XXNORM + ZBAR**2) GAMMA = SQRT(GAMBAR**2 + THETA**2) CS2 = GAMBAR/GAMMA SN2 = THETA/GAMMA Z = RHS/GAMMA XXNORM = XXNORM + Z**2 C C C TEST FOR CONVERGENCE. C FIRST, ESTIMATE THE NORM AND CONDITION OF THE MATRIX ABAR, C AND THE NORMS OF RBAR AND ABAR(TRANSPOSE)*RBAR. C ANORM = SQRT(BBNORM) ACOND = ANORM*SQRT(DDNORM) RES1 = PHIBAR**2 RES2 = RES2 + PSI**2 RNORM = SQRT(RES1 + RES2) ARNORM = ALFA*ABS(TAU) C C NOW USE THESE NORMS TO ESTIMATE CERTAIN OTHER QUANTITIES, C SOME OF WHICH WILL BE SMALL NEAR A SOLUTION. C TEST1 = RNORM/BNORM TEST2 = ARNORM/(ANORM*RNORM) TEST3 = ONE/ACOND T1 = TEST1/(ONE + ANORM*XNORM/BNORM) RTOL = BTOL + ATOL*ANORM*XNORM/BNORM C C THE FOLLOWING TESTS GUARD AGAINST EXTREMELY SMALL VALUES OF C ATOL, BTOL, OR CTOL. (THE USER MAY HAVE SET ANY OR ALL OF C THE PARAMETERS ATOL, BTOL, CONLIM TO ZERO.) C THE EFFECT IS EQUIVALENT TO THE NORMAL TESTS USING C ATOL = RELPR, BTOL = RELPR, CONLIM = 1/RELPR. C T3 = ONE + TEST3 T2 = ONE + TEST2 T1 = ONE + T1 IF (ITN .GE. ITNLIM) ISTOP = 7 IF (T3 .LE. ONE ) ISTOP = 6 IF (T2 .LE. ONE ) ISTOP = 5 IF (T1 .LE. ONE ) ISTOP = 4 C C ALLOW FOR TOLERANCES SET BY THE USER. C IF (TEST3 .LE. CTOL) ISTOP = 3 IF (TEST2 .LE. ATOL) ISTOP = 2 IF (TEST1 .LE. RTOL) ISTOP = 1 C C STOP IF APPROPRIATE. C THE CONVERGENCE CRITERIA ARE REQUIRED TO BE MET ON NCONV C CONSECUTIVE ITERATIONS, WHERE NCONV IS SET BELOW. C SUGGESTED VALUE -- NCONV = 1, 2 OR 3. C IF (ISTOP .EQ. 0) NSTOP = 0 IF (ISTOP .EQ. 0) GO TO 100 NCONV = 1 NSTOP = NSTOP + 1 IF (NSTOP .LT. NCONV .AND. ITN .LT. ITNLIM) ISTOP = 0 IF (ISTOP .EQ. 0) GO TO 100 C ------------------------------------------------------------------ C END OF ITERATION LOOP. C ------------------------------------------------------------------ C 800 RETURN END SUBROUTINE BLSQ(M,N,A,KA,ML,MU,DAMP,U,X,ATOL,BTOL,CONLIM,ITNLIM, * ISTOP,ITN,ACOND,RNORM,XNORM,W) C INTEGER M,N,KA,ML,MU,ITNLIM,ISTOP REAL A(KA,N),DAMP,U(M),X(N),ATOL,BTOL,CONLIM, * ACOND,RNORM,XNORM,W(*) C ------------------------------------------------------------------ C C BLSQ FINDS A SOLUTION X TO THE FOLLOWING PROBLEMS ... C C 1. UNSYMMETRIC EQUATIONS -- SOLVE A*X = B C C 2. LINEAR LEAST SQUARES -- SOLVE A*X = B C IN THE LEAST-SQUARES SENSE C C 3. DAMPED LEAST SQUARES -- SOLVE ( A )*X = ( B ) C ( DAMP*I ) ( 0 ) C IN THE LEAST-SQUARES SENSE C C WHERE A IS A MATRIX WITH M ROWS AND N COLUMNS, B AN M-VECTOR, C AND DAMP A SCALAR. (ALL QUANTITIES ARE REAL.) THE MATRIX A IS C A BANDED MATRIX STORED IN BAND FORM. C C THE RHS VECTOR B IS INPUT VIA U, AND IS SUBSEQUENTLY OVERWRITTEN. C C C NOTE. BLSQ USES AN ITERATIVE METHOD TO APPROXIMATE THE SOLUTION. C THE NUMBER OF ITERATIONS REQUIRED TO REACH A CERTAIN ACCURACY C DEPENDS STRONGLY ON THE SCALING OF THE PROBLEM. POOR SCALING OF C THE ROWS OR COLUMNS OF A SHOULD THEREFORE BE AVOIDED WHENEVER C POSSIBLE. C C FOR EXAMPLE, IN PROBLEM 1 THE SOLUTION IS UNALTERED BY C ROW-SCALING. IF A ROW OF A IS VERY SMALL OR LARGE COMPARED TO C THE OTHER ROWS OF A, THE CORRESPONDING ROW OF (A B) SHOULD BE C SCALED UP OR DOWN. C C IN PROBLEMS 1 AND 2, THE SOLUTION X IS EASILY RECOVERED C FOLLOWING COLUMN SCALING. IN THE ABSENCE OF BETTER INFORMATION, C THE NONZERO COLUMNS OF A SHOULD BE SCALED SO THAT THEY ALL HAVE C THE SAME EUCLIDEAN NORM (E.G. 1.0). C C IN PROBLEM 3, THERE IS NO FREEDOM TO RE-SCALE IF DAMP IS C NONZERO. HOWEVER, THE VALUE OF DAMP SHOULD BE ASSIGNED ONLY C AFTER ATTENTION HAS BEEN PAID TO THE SCALING OF A. C C THE PARAMETER DAMP IS INTENDED TO HELP REGULARIZE C ILL-CONDITIONED SYSTEMS, BY PREVENTING THE TRUE SOLUTION FROM C BEING VERY LARGE. ANOTHER AID TO REGULARIZATION IS PROVIDED BY C THE PARAMETER ACOND, WHICH MAY BE USED TO TERMINATE ITERATIONS C BEFORE THE COMPUTED SOLUTION BECOMES VERY LARGE. C C C NOTATION C -------- C C THE FOLLOWING QUANTITIES ARE USED IN DISCUSSING THE SUBROUTINE C PARAMETERS... C C ABAR = ( A ), BBAR = ( B ) C ( DAMP*I ) ( 0 ) C C R = B - A*X, RBAR = BBAR - ABAR*X C C RNORM = SQRT( NORM(R)**2 + DAMP**2 * NORM(X)**2 ) C = NORM( RBAR ) C C RELPR = THE SMALLEST FLOATING POINT NUMBER FOR WHICH C 1 + RELPR .GT. 1. C C BLSQ MINIMIZES THE FUNCTION RNORM WITH RESPECT TO X. C C C PARAMETERS C ---------- C C M INPUT THE NUMBER OF ROWS IN A. C C N INPUT THE NUMBER OF COLUMNS IN A. C C A INPUT THE MATRIX A STORED IN BAND FORM. C C KA INPUT THE NUMBER OF ROWS IN THE DIMENSION STATEMENT C FOR A IN THE CALLING PROGRAM. C C ML INPUT THE LOWER BAND WIDTH OF A. C C MU INPUT THE UPPER BAND WIDTH OF A. C C DAMP INPUT THE DAMPING PARAMETER FOR PROBLEM 3 ABOVE. C (DAMP SHOULD BE 0.0 FOR PROBLEMS 1 AND 2.) C IF THE SYSTEM A*X = B IS INCOMPATIBLE, VALUES C OF DAMP IN THE RANGE 0 TO SQRT(RELPR)*NORM(A) C WILL PROBABLY HAVE A NEGLIGIBLE EFFECT. C LARGER VALUES OF DAMP WILL TEND TO DECREASE C THE NORM OF X AND TO REDUCE THE NUMBER OF C ITERATIONS REQUIRED BY BLSQ. C C THE WORK PER ITERATION AND THE STORAGE NEEDED C BY BLSQ ARE THE SAME FOR ALL VALUES OF DAMP. C C U(M) INPUT THE RHS VECTOR B. BE AWARE THAT U IS C OVER-WRITTEN BY BLSQ. C C X(N) OUTPUT RETURNS THE COMPUTED SOLUTION X. C C ATOL INPUT AN ESTIMATE OF THE RELATIVE ERROR IN THE DATA C DEFINING THE MATRIX A. FOR EXAMPLE, C IF A IS ACCURATE TO ABOUT 6 DIGITS, SET C ATOL = 1.0E-6 . C C BTOL INPUT AN ESTIMATE OF THE RELATIVE ERROR IN THE DATA C DEFINING THE RHS VECTOR B. FOR EXAMPLE, C IF B IS ACCURATE TO ABOUT 6 DIGITS, SET C BTOL = 1.0E-6 . C C CONLIM INPUT AN UPPER LIMIT ON COND(ABAR), THE APPARENT C CONDITION NUMBER OF THE MATRIX ABAR. C ITERATIONS WILL BE TERMINATED IF A COMPUTED C ESTIMATE OF COND(ABAR) EXCEEDS CONLIM. C THIS IS INTENDED TO PREVENT CERTAIN SMALL OR C ZERO SINGULAR VALUES OF A OR ABAR FROM C COMING INTO EFFECT AND CAUSING UNWANTED GROWTH C IN THE COMPUTED SOLUTION. C C CONLIM AND DAMP MAY BE USED SEPARATELY OR C TOGETHER TO REGULARIZE ILL-CONDITIONED SYSTEMS. C C NORMALLY, CONLIM SHOULD BE IN THE RANGE C 1000 TO 1/RELPR. C SUGGESTED VALUE -- C CONLIM = 1/(100*RELPR) FOR COMPATIBLE SYSTEMS, C CONLIM = 1/(10*SQRT(RELPR)) FOR LEAST SQUARES. C C NOTE. IF THE USER IS NOT CONCERNED ABOUT THE PARAMETERS C ATOL, BTOL, AND CONLIM, ANY OR ALL OF THEM MAY BE SET C TO ZERO. THE EFFECT WILL BE THE SAME AS THE VALUES C RELPR, RELPR, AND 1/RELPR RESPECTIVELY. C C ITNLIM INPUT AN UPPER LIMIT ON THE NUMBER OF ITERATIONS. C SUGGESTED VALUE -- C ITNLIM = N/2 FOR WELL CONDITIONED SYSTEMS, C ITNLIM = 4*N OTHERWISE. C C ISTOP OUTPUT AN INTEGER GIVING THE REASON FOR TERMINATION... C C 0 X = 0 IS THE EXACT SOLUTION. C NO ITERATIONS WERE PERFORMED. C C 1 THE EQUATIONS A*X = B ARE PROBABLY C COMPATIBLE. NORM(A*X - B) IS SUFFICIENTLY C SMALL, GIVEN THE VALUES OF ATOL AND BTOL. C C 2 THE SYSTEM A*X = B IS PROBABLY NOT C COMPATIBLE. A LEAST-SQUARES SOLUTION HAS C BEEN OBTAINED WHICH IS SUFFICIENTLY ACCURATE, C GIVEN THE VALUE OF ATOL. C C 3 AN ESTIMATE OF COND(ABAR) HAS EXCEEDED C CONLIM. THE SYSTEM A*X = B APPEARS TO BE C ILL-CONDITIONED. C C 4 THE EQUATIONS A*X = B ARE PROBABLY C COMPATIBLE. NORM(A*X - B) IS AS SMALL AS C SEEMS REASONABLE ON THIS MACHINE. C C 5 THE SYSTEM A*X = B IS PROBABLY NOT C COMPATIBLE. A LEAST-SQUARES SOLUTION HAS C BEEN OBTAINED WHICH IS AS ACCURATE AS SEEMS C REASONABLE ON THIS MACHINE. C C 6 COND(ABAR) SEEMS TO BE SO LARGE THAT THERE IS C NOT MUCH POINT IN DOING FURTHER ITERATIONS, C GIVEN THE PRECISION OF THIS MACHINE. C C 7 THE ITERATION LIMIT ITNLIM WAS REACHED. C C C ITN OUTPUT THE NUMBER OF ITERATIONS THAT WERE PERFORMED. C C ACOND OUTPUT AN ESTIMATE OF COND(ABAR), THE CONDITION C NUMBER OF ABAR. C C RNORM OUTPUT AN ESTIMATE OF THE FINAL VALUE OF NORM(RBAR), C THE FUNCTION BEING MINIMIZED (SEE NOTATION C ABOVE). THIS WILL BE SMALL IF A*X = B HAS C A SOLUTION. C C XNORM OUTPUT AN ESTIMATE OF THE NORM OF THE FINAL C SOLUTION VECTOR X. C C W(2*N) WORKSPACE C C ANORM LOCAL AN ESTIMATE OF THE FROBENIUS NORM OF ABAR. C THIS IS THE SQUARE ROOT OF THE SUM OF SQUARES C OF THE ELEMENTS OF ABAR. C IF DAMP IS SMALL AND IF THE COLUMNS OF A C HAVE ALL BEEN SCALED TO HAVE LENGTH 1.0, C ANORM SHOULD INCREASE TO ROUGHLY SQRT(N). C C ARNORM LOCAL AN ESTIMATE OF THE FINAL VALUE OF C NORM( ABAR(TRANSPOSE)*RBAR ), THE NORM OF C THE RESIDUAL FOR THE USUAL NORMAL EQUATIONS. C THIS SHOULD BE SMALL IN ALL CASES. (ARNORM C WILL OFTEN BE SMALLER THAN THE TRUE VALUE C COMPUTED FROM THE OUTPUT VECTOR X.) C C C SUBROUTINES AND FUNCTIONS USED C ------------------------------ C C NORMLZ,BVPRD1,BTPRD1 C BLAS SCOPY,SNRM2,SSCAL (SEE LAWSON ET AL. BELOW) C (SNRM2 IS USED ONLY IN NORMLZ) C FORTRAN ABS,SQRT C C C REFERENCES C ---------- C C PAIGE, C.C. AND SAUNDERS, M.A. LSQR, AN ALGORITHM FOR SPARSE C LINEAR EQUATIONS AND SPARSE LEAST SQUARES. C ACM TRANSACTIONS ON MATHEMATICAL SOFTWARE 8, 1 (MARCH 1982). C C LAWSON, C.L., HANSON, R.J., KINCAID, D.R. AND KROGH, F.T. C BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE. C ACM TRANSACTIONS ON MATHEMATICAL SOFTWARE 5, 3 (SEPT 1979), C 308-323 AND 324-325. C C ------------------------------------------------------------------ C C LOCAL VARIABLES C INTEGER I,ITN,NCONV,NSTOP REAL ALFA,ANORM,ARNORM,BBNORM,BETA,BNORM, 1 CS,CS1,CS2,CTOL,DAMPSQ,DDNORM,DELTA, 2 GAMMA,GAMBAR,ONE,PHI,PHIBAR,PSI, 3 RES1,RES2,RHO,RHOBAR,RHBAR1,RHBAR2,RHS,RTOL, 4 SN,SN1,SN2,T,TAU,TEST1,TEST2,TEST3, 5 THETA,T1,T2,T3,XXNORM,Z,ZBAR,ZERO C C C INITIALIZE. C ZERO = 0.0 ONE = 1.0 CTOL = ZERO IF (CONLIM .GT. ZERO) CTOL = ONE/CONLIM DAMPSQ = DAMP**2 ANORM = ZERO ACOND = ZERO BBNORM = ZERO DDNORM = ZERO RES2 = ZERO XNORM = ZERO XXNORM = ZERO CS2 = -ONE SN2 = ZERO Z = ZERO ITN = 0 ISTOP = 0 NSTOP = 0 C DO 10 I = 1, N W(I) = ZERO X(I) = ZERO 10 CONTINUE C C SET UP THE FIRST VECTORS FOR THE BIDIAGONALIZATION. C THESE SATISFY BETA*U = B, ALFA*W = A(TRANSPOSE)*U. C CALL NORMLZ(M,U,BETA) CALL BTPRD1(M,N,A,KA,ML,MU,U,W) CALL NORMLZ(N,W,ALFA) CALL SCOPY (N,W,1,W(N+1),1) C RHOBAR = ALFA PHIBAR = BETA BNORM = BETA RNORM = BETA ARNORM = ALFA*BETA IF (ARNORM .LE. ZERO) GO TO 800 C C ------------------------------------------------------------------ C MAIN ITERATION LOOP. C ------------------------------------------------------------------ 100 ITN = ITN + 1 C C PERFORM THE NEXT STEP OF THE BIDIAGONALIZATION TO OBTAIN THE C NEXT BETA, U, ALFA, W. THESE SATISFY THE RELATIONS C BETA*U = A*W - ALFA*U, C ALFA*W = A(TRANSPOSE)*U - BETA*W. C CALL SSCAL (M,(-ALFA),U,1) CALL BVPRD1(M,N,A,KA,ML,MU,W,U) CALL NORMLZ(M,U,BETA) BBNORM = BBNORM + ALFA**2 + BETA**2 + DAMPSQ CALL SSCAL (N,(-BETA),W,1) CALL BTPRD1(M,N,A,KA,ML,MU,U,W) CALL NORMLZ(N,W,ALFA) C C C USE A PLANE ROTATION TO ELIMINATE THE DAMPING PARAMETER. C THIS ALTERS THE DIAGONAL (RHOBAR) OF THE LOWER-BIDIAGONAL MATRIX. C RHBAR2 = RHOBAR**2 + DAMPSQ RHBAR1 = SQRT(RHBAR2) CS1 = RHOBAR/RHBAR1 SN1 = DAMP/RHBAR1 PSI = SN1*PHIBAR PHIBAR = CS1*PHIBAR C C C USE A PLANE ROTATION TO ELIMINATE THE SUBDIAGONAL ELEMENT (BETA) C OF THE LOWER-BIDIAGONAL MATRIX, GIVING AN UPPER-BIDIAGONAL MATRIX. C RHO = SQRT(RHBAR2 + BETA**2) CS = RHBAR1/RHO SN = BETA/RHO THETA = SN*ALFA RHOBAR = -CS*ALFA PHI = CS*PHIBAR PHIBAR = SN*PHIBAR TAU = SN*PHI C C C UPDATE X AND W(N+1),...,W(2*N) C T1 = PHI/RHO T2 = -THETA/RHO T3 = ONE/RHO C DO 200 I = 1, N NPI = N + I T = W(NPI) X(I) = T1*T + X(I) W(NPI)= T2*T + W(I) T =(T3*T)**2 DDNORM= T + DDNORM 200 CONTINUE C C C USE A PLANE ROTATION ON THE RIGHT TO ELIMINATE THE C SUPER-DIAGONAL ELEMENT (THETA) OF THE UPPER-BIDIAGONAL MATRIX. C THEN USE THE RESULT TO ESTIMATE NORM(X). C DELTA = SN2*RHO GAMBAR = -CS2*RHO RHS = PHI - DELTA*Z ZBAR = RHS/GAMBAR XNORM = SQRT(XXNORM + ZBAR**2) GAMMA = SQRT(GAMBAR**2 + THETA**2) CS2 = GAMBAR/GAMMA SN2 = THETA/GAMMA Z = RHS/GAMMA XXNORM = XXNORM + Z**2 C C C TEST FOR CONVERGENCE. C FIRST, ESTIMATE THE NORM AND CONDITION OF THE MATRIX ABAR, C AND THE NORMS OF RBAR AND ABAR(TRANSPOSE)*RBAR. C ANORM = SQRT(BBNORM) ACOND = ANORM*SQRT(DDNORM) RES1 = PHIBAR**2 RES2 = RES2 + PSI**2 RNORM = SQRT(RES1 + RES2) ARNORM = ALFA*ABS(TAU) C C NOW USE THESE NORMS TO ESTIMATE CERTAIN OTHER QUANTITIES, C SOME OF WHICH WILL BE SMALL NEAR A SOLUTION. C TEST1 = RNORM/BNORM TEST2 = ARNORM/(ANORM*RNORM) TEST3 = ONE/ACOND T1 = TEST1/(ONE + ANORM*XNORM/BNORM) RTOL = BTOL + ATOL*ANORM*XNORM/BNORM C C THE FOLLOWING TESTS GUARD AGAINST EXTREMELY SMALL VALUES OF C ATOL, BTOL, OR CTOL. (THE USER MAY HAVE SET ANY OR ALL OF C THE PARAMETERS ATOL, BTOL, CONLIM TO ZERO.) C THE EFFECT IS EQUIVALENT TO THE NORMAL TESTS USING C ATOL = RELPR, BTOL = RELPR, CONLIM = 1/RELPR. C T3 = ONE + TEST3 T2 = ONE + TEST2 T1 = ONE + T1 IF (ITN .GE. ITNLIM) ISTOP = 7 IF (T3 .LE. ONE ) ISTOP = 6 IF (T2 .LE. ONE ) ISTOP = 5 IF (T1 .LE. ONE ) ISTOP = 4 C C ALLOW FOR TOLERANCES SET BY THE USER. C IF (TEST3 .LE. CTOL) ISTOP = 3 IF (TEST2 .LE. ATOL) ISTOP = 2 IF (TEST1 .LE. RTOL) ISTOP = 1 C C STOP IF APPROPRIATE. C THE CONVERGENCE CRITERIA ARE REQUIRED TO BE MET ON NCONV C CONSECUTIVE ITERATIONS, WHERE NCONV IS SET BELOW. C SUGGESTED VALUE -- NCONV = 1, 2 OR 3. C IF (ISTOP .EQ. 0) NSTOP = 0 IF (ISTOP .EQ. 0) GO TO 100 NCONV = 1 NSTOP = NSTOP + 1 IF (NSTOP .LT. NCONV .AND. ITN .LT. ITNLIM) ISTOP = 0 IF (ISTOP .EQ. 0) GO TO 100 C ------------------------------------------------------------------ C END OF ITERATION LOOP. C ------------------------------------------------------------------ C 800 RETURN END SUBROUTINE FMIN(F, A0, B0, X, W, AERR, RERR, ERROR, IND) C ****************************************************************** C GOLDEN SECTION MINIMIZATION OF A FUNCTION F(T) C ****************************************************************** REAL F, A0, B0, X, W, AERR, RERR, ERROR REAL EPS, EPS0, ATOL, FTOL, RTOL, TOL REAL A, B, C1, C2, E, FU, FV, U, V REAL SPMPAR EXTERNAL F C ------------------- C C1 = 1 - C2 C C2 = 0.5*(-1 + SQRT(5)) C ------------------- DATA EPS0/5.E-3/ DATA C1/.3819660112501052/ DATA C2/.6180339887498948/ C ------------------- C ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE C SMALLEST NUMBER SUCH THAT 1 + EPS .GT. 1. C EPS = SPMPAR(1) C ------------------- A = A0 B = B0 IND = 0 ATOL = AMAX1(AERR,1.E-20) FTOL = AMAX1(2.0*EPS,RERR) RTOL = AMAX1(7.0*EPS,RERR) C E = B - A U = A + C1*E V = A + C2*E FU = F(U) FV = F(V) C C LOCATION OF THE REGION OF A LOCAL MINIMUM C 10 IF (E .LE. EPS0*(1.0 + ABS(A))) GO TO 40 IF (FU - FV) 20,11,30 11 IF (FU .GT. F(B)) GO TO 30 C 20 B = V E = B - A V = U U = A + C1*E FV = FU FU = F(U) GO TO 10 C 30 A = U E = B - A U = V V = A + C2*E FU = FV FV = F(V) GO TO 10 C 40 IF (A .GT. 0.0 .OR. B .LT. 0.0) GO TO 41 W = F(0.0) IF (W .LE. AMIN1(FU,FV)) GO TO 100 41 IF (A .NE. A0) GO TO 42 IF (A .EQ. 0.0) GO TO 201 W = F(A) IF (W .LE. AMIN1(FU,FV)) GO TO 130 GO TO 201 42 IF (B .NE. B0) GO TO 201 IF (B .EQ. 0.0) GO TO 201 W = F(B) IF (W .LE. AMIN1(FU,FV)) GO TO 150 GO TO 201 C C CHECK IF 0 IS A LOCAL MINIMUM C 100 IF (B .LE. ATOL) GO TO 110 X = 0.01*B IF (W .GT. F(X)) GO TO 180 B = X GO TO 100 C 110 IF (ABS(A) .LE. ATOL) GO TO 120 X = 0.01*A IF (W .GT. F(X)) GO TO 180 A = X GO TO 110 C 120 X = 0.0 ERROR = AMAX1(ABS(A),B) RETURN C C CHECK IF A0 IS A LOCAL MINIMUM C 130 TOL = AMAX1(RTOL*ABS(A),ATOL) 131 X = A + 0.01*E IF (W .GT. F(X)) GO TO 180 B = X E = B - A IF (E .GT. TOL) GO TO 131 C X = A ERROR = E RETURN C C CHECK IF B0 IS A LOCAL MINIMUM C 150 TOL = AMAX1(RTOL*ABS(B),ATOL) 151 X = B - 0.01*E IF (W .GT. F(X)) GO TO 180 A = X E = B - A IF (E .GT. TOL) GO TO 151 C X = B ERROR = E RETURN C 180 E = B - A U = A + C1*E V = A + C2*E FU = F(U) FV = F(V) C C REFINEMENT OF THE LOCAL MINIMUM C 200 IND = 0 201 IF (FU .GT. FV) GO TO 210 C B = V E = B - A V = U U = A + C1*E FV = FU FU = F(U) GO TO 220 C 210 A = U E = B - A U = V V = A + C2*E FU = FV FV = F(V) C C CHECKING THE ACCURACY OF THE LOCAL MINIMUM C 220 IF (E .LE. AMAX1(RTOL*ABS(A),ATOL)) GO TO 240 IF (ABS(FV - FU) .GT. FTOL*AMAX1(ABS(FU),ABS(FV))) GO TO 200 IF (IND .EQ. 1) GO TO 241 IND = 1 GO TO 201 C C REPORT THE RESULTS C 240 IND = 0 241 IF (FU - FV) 242,243,244 242 X = U W = FU ERROR = C1*E RETURN 243 X = V W = FV ERROR = E RETURN 244 X = V W = FV ERROR = C1*E RETURN END SUBROUTINE OPTF (FCN,N,RERR,ITER,XPLS,FPLS,IERR,WRK) C----------------------------------------------------------------------- C INTERFACE TO MINIMIZATION PACKAGE C----------------------------------------------------------------------- C C INPUT ... C C FCN NAME OF ROUTINE TO EVALUATE MINIMIZATION FUNCTION. C MUST BE DECLARED EXTERNAL IN CALLING ROUTINE. C N DIMENSION OF PROBLEM C RERR RELATIVE ACCURACY OF SUBROUTINE FCN. C C INPUT/OUTPUT ... C C ITER ON INPUT ITER IS THE MAXIMUM NUMBER OF ITERATIONS C THAT ARE PERMITTED. ON OUTPUT ITER IS THE NUMBER C OF ITERATIONS THAT WERE ACTUALLY PERFORMED. C XPLS(N) LOCAL MINIMUM C C OUTPUT ... C C FPLS FUNCTION VALUE AT LOCAL MINIMUM XPLS C IERR TERMINATION CODE C C WORKSPACE ... C C WRK(N,N+8) C C----------------------------------------------------------------------- REAL XPLS(N), WRK(N,*) EXTERNAL FCN C C EQUIVALENCE WRK(N,1) = X(N) C WRK(N,2) = TYPSIZ(N) C WRK(N,3) = GPLS(N) C WRK(N,4) = G(N) C WRK(N,5) = P(N) C WRK(N,6) = WRK0(N) C WRK(N,7) = WRK1(N) C WRK(N,8) = WRK2(N) C WRK(N,9) = A(N,N) C C C SET TOLERANCES C EPS = AMAX1(SPMPAR(1),ABS(RERR)) GRADTL = EPS**0.4 STEPMX = 0.0 STEPTL = EPS IF (EPS .LE. 1.E-10) STEPTL = 10.0*EPS IF (EPS .LT. 1.E-13) STEPTL = 1.E2*EPS C C INITIALIZATION C MO = 0 ITNLIM = ITER ITER = 0 DO 10 I = 1,N WRK(I,1) = XPLS(I) WRK(I,2) = 1.0 10 CONTINUE FSCALE = 1.0 C C OPTIMIZE FCN C 20 CALL OPTDRV(MO,N,N,WRK(1,1),FCN,WRK(1,2),FSCALE,RERR, * ITNLIM,ITNCNT,GRADTL,STEPMX,STEPTL,XPLS,FPLS,WRK(1,3), * IERR,WRK(1,9),WRK(1,4),WRK(1,5),WRK(1,6),WRK(1,7), * WRK(1,8)) ITER = ITER + ITNCNT IF (IERR .NE. -10) RETURN ITNLIM = ITNLIM - ITNCNT GO TO 20 END SUBROUTINE OPTDRV (MO,NR,N,X,FCN,TYPSIZ,FSCALE,RERR, * ITNLIM,ITNCNT,GRADTL,STEPMX,STEPTL,XPLS,FPLS,GPLS, * IERR,A,G,P,WRK0,WRK1,WRK2) C----------------------------------------------------------------------- C DRIVER FOR NON-LINEAR OPTIMIZATION PROBLEM C----------------------------------------------------------------------- C C INPUT ... C C NR ROW DIMENSION OF MATRIX C N DIMENSION OF PROBLEM C FCN SUBROUTINE. FCN EVALUATES THE FUNCTION TO BE C OPTIMIZED. FCN MUST BE DECLARED EXTERNAL IN THE C CALLING PROGRAM. THE ROUTINE HAS THE FORMAT C CALL FCN (N, X, FVAL) C WHERE X IS A POINT AND FVAL IS THE VALUE OF THE C FUNCTION AT THE POINT. C RERR RELATIVE ACCURACY OF SUBROUTINE FCN. IT IS C ASSUMED THAT RERR IS NONNEGATIVE. IF RERR = 0 C THEN FCN IS ACCURATE TO MACHINE PRECISION. C ITNLIM MAXIMUM NUMBER OF ALLOWABLE ITERATIONS C GRADTL TOLERANCE AT WHICH THE GRADIENT IS CONSIDERED C CLOSE ENOUGH TO ZERO TO TERMINATE ALGORITHM. C (USED ONLY IN THE SUBROUTINE OPSTP.) C STEPTL RELATIVE STEP SIZE AT WHICH SUCCESSIVE ITERATES C CONSIDERED CLOSE ENOUGH TO TERMINATE ALGORITHM C C INPUT/OUTPUT ... C C MO NUMBER OF RESCALINGS OF THE VARIABLES. C X(N) ESTIMATE OF A LOCAL MINIMUM OF FCN C TYPSIZ(N) TYPICAL SIZE FOR EACH COMPONENT OF X C FSCALE ESTIMATE OF SCALE OF MINIMUM VALUE OF FCN. C (USED ONLY IN THE SUBROUTINE OPSTP.) C STEPMX MAXIMUM ALLOWABLE STEP SIZE C C OUTPUT ... C C ITNCNT NUMBER OF ITERATIONS COMPLETED C XPLS(N) ESTIMATE OF A LOCAL MINIMUM OF FCN C FPLS FUNCTION VALUE AT XPLS C GPLS(N) GRADIENT AT XPLS C IERR TERMINATION CODE C C WORK SPACES ... C C A(N,N) CHOLESKY DECOMPOSITION OF HESSIAN C G(N) GRADIENT AT THE CURRENT ITERATE C P(N) STEP C WRK0(N) WORKSPACE C WRK1(N) WORKSPACE C WRK2(N) WORKSPACE C C----------------------------------------------------------------------- C INTERNAL PARAMETERS ... C C RNF NOISE IN THE SUBROUTINE FCN C F FUNCTION VALUE FCN(X) C FSTACK(NS) STACK OF PREVIOUS FUNCTION VALUES C NS LENGTH OF THE ARRAY FSTACK C SPTR POINTER TO AN ELEMENT IN FSTACK C----------------------------------------------------------------------- DIMENSION X(N),XPLS(N),G(N),GPLS(N),P(N) DIMENSION TYPSIZ(N),A(NR,N) DIMENSION WRK0(N),WRK1(N),WRK2(N) DIMENSION FSTACK(30) INTEGER SPTR LOGICAL MXTAKE,NOUPDT EXTERNAL FCN C C INITIALIZATION C -------------- NS = 30 STMX = STEPMX STEPMX = 0.0 CALL OPCHK1 (N,X,TYPSIZ,FSCALE,GRADTL,ITNLIM,RERR,STEPMX,IERR) IF (IERR .LT. 0) RETURN IF (MO .NE. 0) STEPMX = AMAX1(STMX,STEPMX) C RNF = 2.0*AMAX1(RERR,SPMPAR(1)) SQRNF = SQRT(RNF) C ITNCNT = 0 IAGFLG = 0 IRETCD = -1 ICSCMX = 0 C C EVALUATE FCN(X) C CALL FCN(N,X,F) C C EVALUATE FINITE DIFFERENCE GRADIENT C CALL FSTOFD (N, X, FCN, F, G, TYPSIZ, SQRNF) C CALL OPSTP (N,X,F,G,WRK1,ITNCNT,ICSCMX,IERR,GRADTL,STEPTL, * TYPSIZ,FSCALE,ITNLIM,IRETCD,MXTAKE,FSTACK,NS,SPTR) IF (IERR .EQ. 0) GO TO 10 IF (MO .NE. 0) GO TO 210 C C APPLY THE FIXED STEP COORDINATE DESCENT PROCEDURE C FOR ONE STEP AND CHECK IF THE GRADIENT IS NONZERO C CALL FXDEC (FCN, N, X, F, 10.0) C STEPMX = 0.0 CALL OPCHK1 (N,X,TYPSIZ,FSCALE,GRADTL,ITNLIM,RERR,STEPMX,IERR) CALL FSTOFD (N, X, FCN, F, G, TYPSIZ, SQRNF) CALL OPSTP (N,X,F,G,WRK1,ITNCNT,ICSCMX,IERR,GRADTL,STEPTL, * TYPSIZ,FSCALE,ITNLIM,IRETCD,MXTAKE,FSTACK,NS,SPTR) IF (IERR .NE. 0) GO TO 210 C C THE HESSIAN WILL BE OBTAINED BY SECANT UPDATES. C SET A TO THE INITIAL HESSIAN. C 10 NM1 = N - 1 DO 21 J = 1,NM1 A(J,J) = 1.0/TYPSIZ(J) JP1 = J + 1 DO 20 I = JP1,N A(I,J) = 0.0 20 CONTINUE 21 CONTINUE A(N,N) = 1.0/TYPSIZ(N) GO TO 101 C C C ITERATION C --------- 100 IF (MO .GT. 1) GO TO 101 IF (MOD(ITNCNT,10) .NE. 0) GO TO 101 IF (ITNCNT + 10 .GE. ITNLIM) GO TO 101 CALL SCALEX (MO, X, TYPSIZ, N, IERR) IF (IERR .EQ. 0) GO TO 101 MO = MO + 1 RETURN 101 ITNCNT = ITNCNT + 1 C C SOLVE A*P = -G FOR NEWTON STEP C 105 DO 110 I = 1,N WRK1(I) = -G(I) 110 CONTINUE CALL LLTSLV(NR,N,A,P,WRK1) C C TAKE A STEP, ARRIVING AT THE POINT XPLS C CALL LNSRCH(N,X,F,G,P,XPLS,FPLS,FCN,MXTAKE,IRETCD, * STEPMX,STEPTL,TYPSIZ) C C IF A SATISFACTORY STEP COULD NOT BE FOUND AND FORWARD DIFFERENCE C GRADIENT WAS USED, RETRY USING A CENTRAL DIFFERENCE GRADIENT. C IF (IRETCD .NE. 1 .OR. IAGFLG .NE. 0) GO TO 120 C C SET IAGFLG FOR CENTRAL DIFFERENCES C IAGFLG = -1 CBRNF = RNF**(1.0/3.0) CALL FSTOCD (N, X, FCN, TYPSIZ, CBRNF, G) GO TO 105 C C CALCULATE GRADIENT AT XPLS C 120 IF (IAGFLG .EQ. 0) GO TO 130 CALL FSTOCD (N, XPLS, FCN, TYPSIZ, CBRNF, GPLS) GO TO 140 130 CALL FSTOFD (N, XPLS, FCN, FPLS, GPLS, TYPSIZ, SQRNF) C C CHECK WHETHER THE STOPPING CRITERIA SATISFIED C 140 CALL OPSTP (N,XPLS,FPLS,GPLS,X,ITNCNT,ICSCMX,IERR,GRADTL,STEPTL, * TYPSIZ,FSCALE,ITNLIM,IRETCD,MXTAKE,FSTACK,NS,SPTR) IF (IERR .NE. 0) GO TO 200 C C EVALUATE HESSIAN AT XPLS C CALL SECFAC(NR,N,X,G,A,XPLS,GPLS,ITNCNT,SQRNF, * NOUPDT,WRK0,WRK1,WRK2) C C UPDATE F, X, AND G C F = FPLS DO 160 I = 1,N X(I) = XPLS(I) G(I) = GPLS(I) 160 CONTINUE GO TO 100 C C TERMINATION C ----------- C RESET XPLS,FPLS,GPLS IF PREVIOUS ITERATE SOLUTION C 200 IF (IERR .NE. 3) RETURN C 210 FPLS = F DO 220 I = 1,N XPLS(I) = X(I) GPLS(I) = G(I) 220 CONTINUE RETURN END SUBROUTINE OPCHK1 (N,X,TYPSIZ,FSCALE,GRADTL,ITNLIM,RERR, * STEPMX,IERR) C----------------------------------------------------------------------- C CHECK INPUT FOR REASONABLENESS C----------------------------------------------------------------------- C C INPUT ... C C N DIMENSION OF PROBLEM C X(N) ESTIMATE OF MINIMUM OF FCN C GRADTL TOLERANCE AT WHICH GRADIENT CONSIDERED CLOSE C ENOUGH TO ZERO TO TERMINATE ALGORITHM C ITNLIM MAXIMUM NUMBER OF ALLOWABLE ITERATIONS C RERR RELATIVE ACCURACY OF SUBROUTINE FCN C C INPUT/OUTPUT ... C C TYPSIZ(N) SCALING VECTOR FOR X C FSCALE ESTIMATE OF SCALE OF OBJECTIVE FUNCTION FCN C STEPMX MAXIMUM STEP SIZE C C OUTPUT ... C C IERR ERROR INDICATOR C C----------------------------------------------------------------------- REAL X(N), TYPSIZ(N) C C CHECK THAT PARAMETERS ONLY TAKE ON ACCEPTABLE VALUES. C IF NOT, SET THEM TO DEFAULT VALUES. C IERR = 0 C C CHECK DIMENSION OF PROBLEM C IF (N .LE. 0) GO TO 805 IF (N .EQ. 1) GO TO 810 C C COMPUTE SCALE MATRIX C DO 10 I = 1,N TYPSIZ(I) = ABS(TYPSIZ(I)) IF (TYPSIZ(I) .EQ. 0.0) TYPSIZ(I) = 1.0 10 CONTINUE C C CHECK MAXIMUM STEP SIZE C IF (STEPMX .GT. 0.0) GO TO 20 STPSIZ = 0.0 DO 15 I = 1, N STPSIZ = STPSIZ + (X(I)/TYPSIZ(I))**2 15 CONTINUE STPSIZ = SQRT(STPSIZ) STEPMX = AMAX1(1.0E3*STPSIZ, 1.0E3) 20 CONTINUE C C CHECK FUNCTION SCALE C FSCALE = ABS(FSCALE) IF (FSCALE .EQ. 0.0) FSCALE = 1.0 C C CHECK GRADIENT TOLERANCE C IF (GRADTL .LT. 0.0) GO TO 815 C C CHECK ITERATION LIMIT C IF (ITNLIM .LE. 0) GO TO 820 C C CHECK THE ACCURACY OF FCN C IF (RERR .LT. 0.0 .OR. RERR .GT. 1.E-4) GO TO 825 RETURN C C ERROR EXITS C 805 IERR = -1 GO TO 895 810 IERR = -2 GO TO 895 815 IERR = -3 GO TO 895 820 IERR = -4 GO TO 895 825 IERR = -5 895 RETURN END SUBROUTINE OPSTP(N,XPLS,FPLS,GPLS,X,ITNCNT,ICSCMX,IERR, * GRADTL,STEPTL,TYPSIZ,FSCALE,ITNLIM,IRETCD,MXTAKE, * FSTACK,NS,SPTR) C----------------------------------------------------------------------- C UNCONSTRAINED MINIMIZATION STOPPING CRITERIA C----------------------------------------------------------------------- C C INPUT ... C C N DIMENSION OF PROBLEM C XPLS(N) NEW ITERATE X(K) C FPLS FUNCTION VALUE AT NEW ITERATE, F(XPLS) C GPLS(N) GRADIENT AT NEW ITERATE, G(XPLS), OR APPROXIMATE C X(N) OLD ITERATE X(K-1) C ITNCNT CURRENT ITERATION K C ICSCMX NUMBER CONSECUTIVE STEPS .GE. STEPMX C GRADTL TOLERANCE AT WHICH RELATIVE GRADIENT CONSIDERED CLOSE C ENOUGH TO ZERO TO TERMINATE ALGORITHM C STEPTL RELATIVE STEP SIZE AT WHICH SUCCESSIVE ITERATES C CONSIDERED CLOSE ENOUGH TO TERMINATE ALGORITHM C TYPSIZ(N) SCALING VECTOR FOR X C ITNLIM MAXIMUM NUMBER OF ALLOWABLE ITERATIONS C IRETCD CODE WHICH WAS SET WHEN THE POINT XPLS WAS OBTAINED C MXTAKE BOOLEAN FLAG INDICATING STEP OF MAXIMUM LENGTH USED C NS LENGTH OF THE ARRAY FSTACK C C INPUT/OUTPUT ... C C FSCALE ESTIMATE OF SCALE OF OBJECTIVE FUNCTION C FSTACK(NS) STACK OF PREVIOUS FUNCTION VALUES C SPTR POINTER TO AN ELEMENT IN FSTACK C C OUTPUT ... C C ICSCMX NUMBER CONSECUTIVE STEPS .GE. STEPMX C (RETAIN VALUE BETWEEN SUCCESSIVE CALLS) C IERR TERMINATION CODE C C----------------------------------------------------------------------- REAL XPLS(N), GPLS(N), X(N), TYPSIZ(N), FSTACK(NS) INTEGER SPTR LOGICAL MXTAKE C IERR = 0 C C LAST GLOBAL STEP FAILED TO LOCATE A POINT LOWER THAN X C IF (IRETCD .NE. 1) GO TO 10 IERR = 3 RETURN 10 CONTINUE C C FIND DIRECTION IN WHICH RELATIVE GRADIENT MAXIMUM. C CHECK WHETHER WITHIN TOLERANCE. C D = AMAX1(ABS(FPLS),FSCALE) RGX = 0.0 DO 20 I = 1,N GRD = ABS(GPLS(I))*AMAX1(ABS(XPLS(I)),TYPSIZ(I)) RGX = AMAX1(RGX, GRD) 20 CONTINUE JERR = 1 IF (RGX .GT. GRADTL*D) GO TO 30 IF (ABS(FPLS) .LE. 1.E-9) GO TO 100 IF (ABS(FPLS) .GT. 0.5*FSCALE) GO TO 100 FSCALE = ABS(FPLS) 30 IF (ITNCNT .EQ. 0) RETURN C C FIND DIRECTION IN WHICH RELATIVE STEPSIZE MAXIMUM C CHECK WHETHER WITHIN TOLERANCE. C RSX = 0.0 DO 40 I = 1,N RELSTP = ABS(XPLS(I) - X(I))/AMAX1(ABS(XPLS(I)),TYPSIZ(I)) RSX = AMAX1(RSX,RELSTP) 40 CONTINUE JERR = 2 IF (RSX .LE. STEPTL) GO TO 100 C C CHECK IF FPLS IS SUFFICIENTLY LESS THAN THE NS-TH C PREVIOUS VALUE OF FCN. C IF (ITNCNT .GT. NS) GO TO 50 SPTR = ITNCNT FSTACK(SPTR) = FPLS GO TO 60 50 SPTR = SPTR + 1 IF (SPTR .GT. NS) SPTR = 1 JERR = 3 IF (FPLS .GE. (FSTACK(SPTR) - 1.E-3*ABS(FSTACK(SPTR)))) * GO TO 100 FSTACK(SPTR) = FPLS C C CHECK ITERATION LIMIT C 60 JERR = 4 IF (ITNCNT .GE. ITNLIM) GO TO 100 C C CHECK NUMBER OF CONSECUTIVE STEPS OF SIZE STEPMX C IF (MXTAKE) GO TO 70 ICSCMX = 0 RETURN 70 ICSCMX = ICSCMX + 1 IF (ICSCMX .GE. 20) IERR = 5 RETURN C C TERMINATE C 100 IERR = JERR RETURN END SUBROUTINE FXDEC (FCN, N, X, FX, R) C----------------------------------------------------------------------- C FIXED STEP COORDINATE DESCENT PROCEDURE / ONE ITERATION C----------------------------------------------------------------------- REAL X(N) EXTERNAL FCN C DO 20 I = 1,N H = R * AMAX1(ABS(X(I)), 1.0) XI = X(I) XPLUS = XI + H X(I) = XPLUS CALL FCN (N, X, FPLUS) XMINUS = XI - 1.1*H X(I) = XMINUS CALL FCN (N, X, FMINUS) X(I) = XI C IF (FX .LE. FPLUS) GO TO 10 FX = FPLUS X(I) = XPLUS 10 IF (FX .LE. FMINUS) GO TO 20 FX = FMINUS X(I) = XMINUS 20 CONTINUE RETURN END SUBROUTINE SCALEX (MO, X, TYPSIZ, N, IERR) REAL X(N), TYPSIZ(N) C----------------------------------------------------------------------- C RESCALE THE VARIABLES C----------------------------------------------------------------------- XMIN = 1.E-5*SPMPAR(3) DO 10 I = 1,N T = AMAX1(ABS(X(I)), 1.E-20) XMIN = AMIN1(T, XMIN) 10 CONTINUE C C = 1.E3 IF (MO .NE. 0) C = 1.E2 BIG = C*XMIN DO 20 I = 1,N IF (ABS(X(I)) .GE. BIG) GO TO 30 20 CONTINUE IERR = 0 RETURN C 30 DO 31 I = 1,N T = ABS(X(I))/C TYPSIZ(I) = AMAX1(T, XMIN) 31 CONTINUE IERR = -10 RETURN END SUBROUTINE LLTSLV (NR,N,A,X,B) C----------------------------------------------------------------------- C SOLUTION OF AX = B WHERE A HAS THE FORM L(L-TRANSPOSE) C BUT ONLY THE LOWER TRIANGULAR PART L IS STORED. C----------------------------------------------------------------------- C C INPUT ... C C NR ROW DIMENSION OF MATRIX C N ORDER OF THE MATRIX C A(N,N) MATRIX OF FORM L(L-TRANSPOSE). A IS NOT C MODIFIED BY THE ROUTINE. C B(N) RIGHT-HAND SIDE VECTOR C C OUTPUT ... C C X(N) SOLUTION VECTOR C C----------------------------------------------------------------------- C NOTE. B AND X MAY SHARE THE SAME STORAGE AREA. C----------------------------------------------------------------------- REAL A(NR,N), X(N), B(N) C C FORWARD SOLVE, RESULT IN X C X(1) = B(1)/A(1,1) IF (N .EQ. 1) GO TO 30 DO 20 I = 2,N SUM = 0.0 IM1 = I - 1 DO 10 J = 1,IM1 SUM = SUM + A(I,J)*X(J) 10 CONTINUE X(I) = (B(I) - SUM)/A(I,I) 20 CONTINUE C C BACK SOLVE, RESULT IN X C 30 X(N) = X(N)/A(N,N) IF (N .EQ. 1) RETURN I = N DO 50 II = 2,N IP1 = I I = I - 1 SUM = 0.0 DO 40 J = IP1,N SUM = SUM + A(J,I)*X(J) 40 CONTINUE X(I) = (X(I) - SUM)/A(I,I) 50 CONTINUE RETURN END SUBROUTINE FSTOFD (N, X, FCN, FX, G, TYPSIZ, R) C----------------------------------------------------------------------- C FIND FORWARD DIFFERENCE APPROXIMATION G TO THE FIRST DERIVATIVE C (GRADIENT) OF THE FUNCTION DEFINED BY FCN AT THE POINT X. C----------------------------------------------------------------------- C C INPUT ... C C N DIMENSION OF PROBLEM C X(N) POINT AT WHICH THE GRADIENT IS TO BE APPROXIMATED C FCN NAME OF SUBROUTINE TO EVALUATE FUNCTION C FX VALUE OF FCN AT THE POINT X C TYPSIZ(N) SCALING VECTOR FOR X C R STEPSIZE FACTOR C C OUTPUT ... C C G(N) FINITE DIFFERENCE APPROXIMATION TO THE GRADIENT C C----------------------------------------------------------------------- DIMENSION X(N), G(N), TYPSIZ(N) EXTERNAL FCN C DO 10 J = 1,N STEPSZ = R * AMAX1(ABS(X(J)),TYPSIZ(J)) XTMPJ = X(J) X(J) = XTMPJ + STEPSZ CALL FCN (N, X, FPLUS) X(J) = XTMPJ G(J) = (FPLUS - FX)/STEPSZ 10 CONTINUE RETURN END SUBROUTINE FSTOCD (N, X, FCN, TYPSIZ, R, G) C----------------------------------------------------------------------- C FIND CENTRAL DIFFERENCE APPROXIMATION G TO THE FIRST DERIVATIVE C (GRADIENT) OF THE FUNCTION DEFINED BY FCN AT THE POINT X. C----------------------------------------------------------------------- C C INPUT ... C C N DIMENSION OF PROBLEM C X(N) POINT AT WHICH GRADIENT IS TO BE APPROXIMATED C FCN NAME OF SUBROUTINE TO EVALUATE FUNCTION C TYPSIZ(N) SCALING VECTOR FOR X C R STEPSIZE FACTOR C C OUTPUT ... C C G(N) CENTRAL DIFFERENCE APPROXIMATION TO GRADIENT C C----------------------------------------------------------------------- REAL X(N), TYPSIZ(N), G(N) EXTERNAL FCN C C FIND I-TH STEPSIZE, EVALUATE TWO NEIGHBORS IN DIRECTION OF C I-TH UNIT VECTOR, AND EVALUATE I-TH COMPONENT OF GRADIENT. C DO 10 I = 1, N STEPI = R * AMAX1(ABS(X(I)),TYPSIZ(I)) XTEMPI = X(I) X(I) = XTEMPI + STEPI CALL FCN (N, X, FPLUS) X(I) = XTEMPI - STEPI CALL FCN (N, X, FMINUS) X(I) = XTEMPI G(I) = (FPLUS - FMINUS)/(2.0*STEPI) 10 CONTINUE RETURN END SUBROUTINE LNSRCH(N,X,F,G,P,XPLS,FPLS,FCN,MXTAKE,IRETCD, * STEPMX,STEPTL,TYPSIZ) C----------------------------------------------------------------------- C FIND A NEXT NEWTON ITERATE BY LINE SEARCH C----------------------------------------------------------------------- C C INPUT ... C C N DIMENSION OF PROBLEM C X(N) OLD ITERATE X(K-1) C F FUNCTION VALUE AT OLD ITERATE, F(X) C G(N) GRADIENT AT OLD ITERATE, G(X) C P(N) NON-ZERO NEWTON STEP C FCN NAME OF SUBROUTINE TO EVALUATE FUNCTION C STEPMX MAXIMUM ALLOWABLE STEP SIZE C STEPTL RELATIVE STEP SIZE AT WHICH SUCCESSIVE ITERATES C CONSIDERED CLOSE ENOUGH TO TERMINATE ALGORITHM C TYPSIZ(N) SCALING VECTOR FOR X C C OUTPUT ... C C XPLS(N) NEW ITERATE X(K) C FPLS FUNCTION VALUE AT NEW ITERATE, F(XPLS) C IRETCD RETURN CODE C MXTAKE BOOLEAN FLAG INDICATING STEP OF MAXIMUM LENGTH USED C C----------------------------------------------------------------------- C INTERNAL VARIABLES ... C C SLN NEWTON LENGTH C RLN RELATIVE LENGTH OF NEWTON STEP C----------------------------------------------------------------------- REAL X(N), G(N), P(N), XPLS(N), TYPSIZ(N) REAL LAMBDA LOGICAL MXTAKE EXTERNAL FCN C MXTAKE = .FALSE. IRETCD = 2 TMP = 0.0 DO 10 I = 1,N TMP = TMP + (P(I)/TYPSIZ(I))**2 10 CONTINUE SLN = SQRT(TMP) C IF (SLN .LE. STEPMX) GO TO 30 C C NEWTON STEP LONGER THAN MAXIMUM ALLOWED C SCL = STEPMX/SLN DO 20 I = 1,N P(I) = SCL*P(I) 20 CONTINUE SLN = STEPMX C 30 SLP = SDOT(N,G,1,P,1) RLN = 0.0 DO 40 I = 1,N RLN = AMAX1(RLN,ABS(P(I))/AMAX1(ABS(X(I)),TYPSIZ(I))) 40 CONTINUE RMNLMB = STEPTL/RLN LAMBDA = 1.0 C C LOOP. CHECK IF THE NEW ITERATE IS SATISFACTORY. C 100 DO 110 I = 1,N XPLS(I) = X(I) + LAMBDA*P(I) 110 CONTINUE CALL FCN(N,XPLS,FPLS) IF (FPLS .LE. F + SLP*1.E-4*LAMBDA) GO TO 200 C C SOLUTION NOT (YET) FOUND C IF (LAMBDA .LT. RMNLMB) GO TO 210 C C CALCULATE NEW LAMBDA C IF (LAMBDA .NE. 1.0) GO TO 120 C C FIRST BACKTRACK. QUADRATIC FIT C TLMBDA = AMIN1(-SLP/(2.0*(FPLS - F - SLP)), 0.9) GO TO 170 C C ALL SUBSEQUENT BACKTRACKS. CUBIC FIT C 120 T1 = (FPLS - F - LAMBDA*SLP)/(LAMBDA*LAMBDA) T2 = (PFPLS - F - PLMBDA*SLP)/(PLMBDA*PLMBDA) T3 = 1.0/(LAMBDA - PLMBDA) A = T3*(T1 - T2) B = T3*(T2*LAMBDA - T1*PLMBDA) W = 10.0*ABS(T1*T3) IF ((ABS(A) + W) .NE. W) GO TO 130 C C THE CUBIC FIT DEGENERATES TO A QUADRATIC FIT C TLMBDA = -SLP/(2.0*B) GO TO 160 C C THE CUBIC IS NONDEGENERATE C 130 DISC = B*B - 3.0*A*SLP IF (DISC .LE. B*B) GO TO 140 C C ONLY ONE POSITIVE CRITICAL POINT, MUST BE MINIMUM C TLMBDA = (-B + SIGN(1.0,A)*SQRT(DISC))/(3.0*A) GO TO 160 C C BOTH CRITICAL POINTS POSITIVE, FIRST IS MINIMUM C 140 IF (DISC .GT. 0.0) GO TO 150 TLMBDA = -B/(3.0*A) GO TO 160 150 TLMBDA = (-B - SIGN(1.0,A)*SQRT(DISC))/(3.0*A) C 160 IF (TLMBDA .GT. 0.5*LAMBDA) TLMBDA = 0.5*LAMBDA C C 170 PLMBDA = LAMBDA PFPLS = FPLS IF (TLMBDA .GE. LAMBDA*0.1) GO TO 180 LAMBDA = LAMBDA*0.1 GO TO 100 180 LAMBDA = TLMBDA GO TO 100 C C A SUITABLE VALUE FOR XPLS HAS BEEN OBTAINED C 200 IRETCD = 0 IF (LAMBDA .EQ. 1.0 .AND. SLN .GT. 0.99*STEPMX) MXTAKE =.TRUE. RETURN C C NO SATISFACTORY XPLS FOUND SUFFICIENTLY DISTINCT FROM X C 210 IRETCD = 1 RETURN END SUBROUTINE SECFAC (NR,N,X,G,A,XPLS,GPLS,ITNCNT,TOL, * NOUPDT,S,Y,W) C----------------------------------------------------------------------- C UPDATE HESSIAN BY THE BFGS FACTORED METHOD C----------------------------------------------------------------------- C C INPUT ... C C NR ROW DIMENSION OF MATRIX C N ORDER OF THE MATRIX C X(N) OLD ITERATE X(K-1) C G(N) GRADIENT AT THE OLD ITERATE C XPLS(N) NEW ITERATE X(K) C GPLS(N) GRADIENT AT THE NEW ITERATE C ITNCNT ITERATION COUNT C TOL RELATIVE TOLERANCE TO BE USED FOR NOISE C C INPUT/OUTPUT ... C C A(N,N) ON ENTRY, CHOLESKY DECOMPOSITION OF HESSIAN IN C THE LOWER PART AND DIAGONAL. C ON EXIT, UPDATED CHOLESKY DECOMPOSITION OF HESSIAN C IN THE LOWER TRIANGULAR PART AND DIAGONAL. C NOUPDT BOOLEAN. NO UPDATE YET. C C WORK SPACES ... S(N), Y(N), W(N) C C----------------------------------------------------------------------- REAL X(N), XPLS(N), G(N), GPLS(N) REAL A(NR,N) REAL S(N), Y(N), W(N) LOGICAL NOUPDT C IF (ITNCNT .EQ. 1) NOUPDT = .TRUE. DO 10 I = 1,N S(I) = XPLS(I) - X(I) Y(I) = GPLS(I) - G(I) 10 CONTINUE DEN1 = SDOT(N,S,1,Y,1) SNORM2 = SNRM2(N,S,1) YNRM2 = SNRM2(N,Y,1) IF (DEN1 .LT. TOL*SNORM2*YNRM2) RETURN C C SET S = TRANSPOSE(L)*S C DO 21 I = 1,N SUM = 0.0 DO 20 J = I,N SUM = SUM + A(J,I)*S(J) 20 CONTINUE S(I) = SUM 21 CONTINUE DEN2 = SDOT(N,S,1,S,1) C C SET ALP = SQRT(DEN1/DEN2) C ALP = SQRT(DEN1/DEN2) IF (.NOT.NOUPDT) GO TO 40 C C ON THE INITIAL UPDATE SET L = ALP*L. THEN S MUST BE C RESET TO ALP*S. AFTER THIS IS DONE THEN DEN2 = DEN1 C AND ALP HAS THE VALUE 1. C DO 31 J = 1,N S(J) = ALP*S(J) DO 30 I = J,N A(I,J) = ALP*A(I,J) 30 CONTINUE 31 CONTINUE NOUPDT = .FALSE. ALP = 1.0 C C SET W = L*S C 40 DO 51 I = 1,N SUM = 0.0 DO 50 J = 1,I SUM = SUM + A(I,J)*S(J) 50 CONTINUE W(I) = SUM 51 CONTINUE C C IF ABS(Y(I) - W(I)) IS LESS THAN THE ESTIMATED NOISE IN Y(I) C FOR EACH I, THEN THE UPDATE IS SKIPPED. C DO 60 I = 1,N IF (ABS(Y(I) - W(I)) .GE. TOL*AMAX1(ABS(G(I)),ABS(GPLS(I)))) * GO TO 70 60 CONTINUE RETURN C C W = Y - ALP*L*S C 70 DO 71 I = 1,N W(I) = Y(I) - ALP*W(I) 71 CONTINUE C C S = S/SQRT(DEN1*DEN2) C ALP = ALP/DEN1 DO 80 I = 1,N S(I) = ALP*S(I) 80 CONTINUE C C COPY L INTO UPPER TRIANGULAR PART. ZERO L. C DO 100 I = 2,N IM1 = I - 1 DO 90 J = 1,IM1 A(J,I) = A(I,J) A(I,J) = 0.0 90 CONTINUE 100 CONTINUE C C FIND Q AND R SUCH THAT Q*R = (L+) + S*(W+) C CALL QRUPDT (NR, N, A, S, W) C C UPPER TRIANGULAR PART AND DIAGONAL OF A NOW CONTAIN UPDATED C CHOLESKY DECOMPOSITION OF HESSIAN. COPY BACK TO LOWER C TRIANGULAR PART. C DO 120 I = 2,N IM1 = I - 1 DO 110 J = 1,IM1 A(I,J) = A(J,I) 110 CONTINUE 120 CONTINUE RETURN END SUBROUTINE QRUPDT (NR,N,A,U,V) C----------------------------------------------------------------------- C FIND AN ORTHOGONAL MATRIX (Q*) AND AN UPPER TRIANGULAR C MATRIX (R*) SUCH THAT (Q*)(R*) = R + U(V+) C----------------------------------------------------------------------- C C PARAMETERS ... C C NR ROW DIMENSION OF THE MATRIX C N ORDER OF THE MATRIX C A(N,N) ON INPUT, CONTAINS R C ON OUTPUT, CONTAINS (R*) C U(N) VECTOR C V(N) VECTOR C C----------------------------------------------------------------------- REAL A(NR,N), U(N), V(N) C C DETERMINE LAST NON-ZERO IN U C K = N 10 IF (U(K) .NE. 0.0 .OR. K .EQ. 1) GO TO 20 K = K - 1 GO TO 10 C C K-1 JACOBI ROTATIONS TRANSFORM C R + U(V+) TO (R*) + (U(1)*E1)(V+) C WHICH IS UPPER HESSENBERG C 20 KM1 = K - 1 IF (K .LE. 1) GO TO 40 DO 30 II = 1,KM1 I = K - II CALL JROT (NR,N,A,I,U(I),-U(I+1),R) U(I) = R 30 CONTINUE C C SET R = R + (U(1)*E1)(V+) C 40 DO 50 J = 1,N A(1,J) = A(1,J) + U(1)*V(J) 50 CONTINUE IF (K .LE. 1) RETURN C C K-1 JACOBI ROTATIONS TRANSFORM UPPER HESSENBERG R C TO UPPER TRIANGULAR R* C DO 60 I = 1,KM1 CALL JROT (NR,N,A,I,A(I,I),-A(I+1,I),R) 60 CONTINUE RETURN END SUBROUTINE JROT (NR,N,H,I,A,B,R) C----------------------------------------------------------------------- C PRE-MULTIPLICATION OF AN UPPER HESSENBERG MATRIX H C BY THE JACOBIAN ROTATION J(I,I+1,A,B) C----------------------------------------------------------------------- C C INPUT ... C C NR ROW DIMENSION OF THE MATRIX C N ORDER OF THE MATRIX C H(N,N) UPPER HESSENBER MATRIX C I INDEX OF ROW C A,B SCALARS C C OUTPUT ... C C H(N,N) THE MODIFIED HESSENBERG MATRIX C R R = SQRT(A*A + B*B) C C----------------------------------------------------------------------- REAL H(NR,N) C C COMPUTE C = A/R AND S = B/R C IF (ABS(A) .LE. ABS(B)) GO TO 10 T = B/A Z = SQRT(1.0 + T*T) C = SIGN(1.0/Z, A) S = T*C R = Z*ABS(A) GO TO 20 10 IF (A .EQ. 0.0) GO TO 40 T = A/B Z = SQRT(1.0 + T*T) S = SIGN(1.0/Z, B) C = T*S R = Z*ABS(B) C C APPLY THE ROTATION WHEN A IS NONZERO C 20 DO 30 J = I,N T = H(I,J) Z = H(I+1,J) H(I,J) = C*T - S*Z H(I+1,J) = S*T + C*Z 30 CONTINUE RETURN C C CASE WHEN A = 0 C 40 S = SIGN(1.0, B) R = ABS(B) DO 50 J = I,N T = H(I,J) H(I,J) = - S*H(I+1,J) H(I+1,J) = S*T 50 CONTINUE RETURN END SUBROUTINE LMDIFF (FCN,M,N,X,FVEC,EPSFCN,TOL,INFO,IWA,WA,LWA) INTEGER M,N,INFO,LWA INTEGER IWA(N) REAL EPSFCN,TOL REAL X(N),FVEC(M),WA(LWA) EXTERNAL FCN C ********** C C SUBROUTINE LMDIFF C C THE PURPOSE OF LMDIFF IS TO MINIMIZE THE SUM OF THE SQUARES OF C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF THE C LEVENBERG-MARQUARDT ALGORITHM. THIS IS DONE BY USING THE MORE C GENERAL LEAST-SQUARES SOLVER LMDIF. THE USER MUST PROVIDE A C SUBROUTINE WHICH CALCULATES THE FUNCTIONS. THE JACOBIAN IS C THEN CALCULATED BY A FORWARD-DIFFERENCE APPROXIMATION. C C THE SUBROUTINE STATEMENT IS C C SUBROUTINE LMDIFF(FCN,M,N,X,FVEC,EPSFCN,TOL,INFO,IWA,WA,LWA) C C WHERE C C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH C CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED C IN AN EXTERNAL STATEMENT IN THE USER CALLING C PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. C C SUBROUTINE FCN(M,N,X,FVEC,IFLAG) C INTEGER M,N,IFLAG C REAL X(N),FVEC(M) C ---------- C CALCULATE THE FUNCTIONS AT X AND C RETURN THIS VECTOR IN FVEC. C ---------- C RETURN C END C C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS C THE USER WANTS TO TERMINATE EXECUTION OF LMDIFF. C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. C C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER C OF FUNCTIONS. C C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER C OF VARIABLES. N MUST NOT EXCEED M. C C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. C C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS C THE FUNCTIONS EVALUATED AT THE OUTPUT X. C C EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE C STEP LENGTH FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS C APPROXIMATION ASSUMES THAT THE RELATIVE ERRORS IN THE C FUNCTIONS ARE OF THE ORDER OF EPSFCN. IF EPSFCN IS LESS C THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE RELATIVE C ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE C PRECISION. C C TOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS C WHEN THE ALGORITHM ESTIMATES EITHER THAT THE RELATIVE C ERROR IN THE SUM OF SQUARES IS AT MOST TOL OR THAT C THE RELATIVE ERROR BETWEEN X AND THE SOLUTION IS AT C MOST TOL. C C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, C INFO IS SET AS FOLLOWS. C C INFO = 0 IMPROPER INPUT PARAMETERS. C C INFO = 1 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR C IN THE SUM OF SQUARES IS AT MOST TOL. C C INFO = 2 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR C BETWEEN X AND THE SOLUTION IS AT MOST TOL. C C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD. C C INFO = 4 FVEC IS ORTHOGONAL TO THE COLUMNS OF THE C JACOBIAN TO MACHINE PRECISION. C C INFO = 5 NUMBER OF CALLS TO FCN HAS REACHED OR C EXCEEDED 200*(N+1). C C INFO = 6 TOL IS TOO SMALL. NO FURTHER REDUCTION IN C THE SUM OF SQUARES IS POSSIBLE. C C INFO = 7 TOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN C THE APPROXIMATE SOLUTION X IS POSSIBLE. C C IWA IS AN INTEGER WORK ARRAY OF LENGTH N. C C WA IS A WORK ARRAY OF LENGTH LWA. C C LWA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN C M*N+5*N+M. C C SUBPROGRAMS CALLED C C USER-SUPPLIED ...... FCN C C MINPACK-SUPPLIED ... LMDIF C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE C C ********** INTEGER MAXFEV,MODE,MP5N,NFEV,NPRINT REAL FACTOR,FTOL,GTOL,XTOL DATA FACTOR /1.0E2/ INFO = 0 C C CHECK THE INPUT PARAMETERS FOR ERRORS. C IF (N .LE. 0 .OR. M .LT. N .OR. EPSFCN .LT. 0.0 * .OR. TOL .LT. 0.0 .OR. LWA .LT. M*N + 5*N + M) GO TO 10 C C CALL LMDIF. C MAXFEV = 200*(N + 1) FTOL = TOL XTOL = TOL GTOL = 0.0 MODE = 1 NPRINT = 0 MP5N = M + 5*N CALL LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN,WA(1), * MODE,FACTOR,NPRINT,INFO,NFEV,WA(MP5N+1),M,IWA, * WA(N+1),WA(2*N+1),WA(3*N+1),WA(4*N+1),WA(5*N+1)) IF (INFO .EQ. 8) INFO = 4 10 CONTINUE RETURN END SUBROUTINE LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN, * DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,LDFJAC, * IPVT,QTF,WA1,WA2,WA3,WA4) INTEGER M,N,MAXFEV,MODE,NPRINT,INFO,NFEV,LDFJAC INTEGER IPVT(N) REAL FTOL,XTOL,GTOL,EPSFCN,FACTOR REAL X(N),FVEC(M),DIAG(N),FJAC(LDFJAC,N),QTF(N),WA1(N),WA2(N), * WA3(N),WA4(M) EXTERNAL FCN C ********** C C SUBROUTINE LMDIF C C THE PURPOSE OF LMDIF IS TO MINIMIZE THE SUM OF THE SQUARES OF C M NONLINEAR FUNCTIONS IN N VARIABLES BY A MODIFICATION OF C THE LEVENBERG-MARQUARDT ALGORITHM. THE USER MUST PROVIDE A C SUBROUTINE WHICH CALCULATES THE FUNCTIONS. THE JACOBIAN IS C THEN CALCULATED BY A FORWARD-DIFFERENCE APPROXIMATION. C C THE SUBROUTINE STATEMENT IS C C SUBROUTINE LMDIF(FCN,M,N,X,FVEC,FTOL,XTOL,GTOL,MAXFEV,EPSFCN, C DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,FJAC, C LDFJAC,IPVT,QTF,WA1,WA2,WA3,WA4) C C WHERE C C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH C CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED C IN AN EXTERNAL STATEMENT IN THE USER CALLING C PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. C C SUBROUTINE FCN(M,N,X,FVEC,IFLAG) C INTEGER M,N,IFLAG C REAL X(N),FVEC(M) C ---------- C CALCULATE THE FUNCTIONS AT X AND C RETURN THIS VECTOR IN FVEC. C ---------- C RETURN C END C C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS C THE USER WANTS TO TERMINATE EXECUTION OF LMDIF. C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. C C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER C OF FUNCTIONS. C C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER C OF VARIABLES. N MUST NOT EXCEED M. C C X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN C AN INITIAL ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X C CONTAINS THE FINAL ESTIMATE OF THE SOLUTION VECTOR. C C FVEC IS AN OUTPUT ARRAY OF LENGTH M WHICH CONTAINS C THE FUNCTIONS EVALUATED AT THE OUTPUT X. C C FTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION C OCCURS WHEN BOTH THE ACTUAL AND PREDICTED RELATIVE C REDUCTIONS IN THE SUM OF SQUARES ARE AT MOST FTOL. C THEREFORE, FTOL MEASURES THE RELATIVE ERROR DESIRED C IN THE SUM OF SQUARES. C C XTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION C OCCURS WHEN THE RELATIVE ERROR BETWEEN TWO CONSECUTIVE C ITERATES IS AT MOST XTOL. THEREFORE, XTOL MEASURES THE C RELATIVE ERROR DESIRED IN THE APPROXIMATE SOLUTION. C C GTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION C OCCURS WHEN THE COSINE OF THE ANGLE BETWEEN FVEC AND C ANY COLUMN OF THE JACOBIAN IS AT MOST GTOL IN ABSOLUTE C VALUE. THEREFORE, GTOL MEASURES THE ORTHOGONALITY C DESIRED BETWEEN THE FUNCTION VECTOR AND THE COLUMNS C OF THE JACOBIAN. C C MAXFEV IS A POSITIVE INTEGER INPUT VARIABLE. TERMINATION C OCCURS WHEN THE NUMBER OF CALLS TO FCN IS AT LEAST C MAXFEV BY THE END OF AN ITERATION. C C EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE C STEP LENGTH FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS C APPROXIMATION ASSUMES THAT THE RELATIVE ERRORS IN THE C FUNCTIONS ARE OF THE ORDER OF EPSFCN. IF EPSFCN IS LESS C THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE RELATIVE C ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE C PRECISION. C C DIAG IS AN ARRAY OF LENGTH N. IF MODE = 1 (SEE C BELOW), DIAG IS INTERNALLY SET. IF MODE = 2, DIAG C MUST CONTAIN POSITIVE ENTRIES THAT SERVE AS C MULTIPLICATIVE SCALE FACTORS FOR THE VARIABLES. C C MODE IS AN INTEGER INPUT VARIABLE. IF MODE = 1, THE C VARIABLES WILL BE SCALED INTERNALLY. IF MODE = 2, C THE SCALING IS SPECIFIED BY THE INPUT DIAG. OTHER C VALUES OF MODE ARE EQUIVALENT TO MODE = 1. C C FACTOR IS A POSITIVE INPUT VARIABLE USED IN DETERMINING THE C INITIAL STEP BOUND. THIS BOUND IS SET TO THE PRODUCT OF C FACTOR AND THE EUCLIDEAN NORM OF DIAG*X IF NONZERO, OR ELSE C TO FACTOR ITSELF. IN MOST CASES FACTOR SHOULD LIE IN THE C INTERVAL (.1,100.). 100. IS A GENERALLY RECOMMENDED VALUE. C C NPRINT IS AN INTEGER INPUT VARIABLE THAT ENABLES CONTROLLED C PRINTING OF ITERATES IF IT IS POSITIVE. IN THIS CASE, C FCN IS CALLED WITH IFLAG = 0 AT THE BEGINNING OF THE FIRST C ITERATION AND EVERY NPRINT ITERATIONS THEREAFTER AND C IMMEDIATELY PRIOR TO RETURN, WITH X AND FVEC AVAILABLE C FOR PRINTING. IF NPRINT IS NOT POSITIVE, NO SPECIAL CALLS C OF FCN WITH IFLAG = 0 ARE MADE. C C INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS C TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE) C VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE, C INFO IS SET AS FOLLOWS. C C INFO = 0 IMPROPER INPUT PARAMETERS. C C INFO = 1 BOTH ACTUAL AND PREDICTED RELATIVE REDUCTIONS C IN THE SUM OF SQUARES ARE AT MOST FTOL. C C INFO = 2 RELATIVE ERROR BETWEEN TWO CONSECUTIVE ITERATES C IS AT MOST XTOL. C C INFO = 3 CONDITIONS FOR INFO = 1 AND INFO = 2 BOTH HOLD. C C INFO = 4 THE COSINE OF THE ANGLE BETWEEN FVEC AND ANY C COLUMN OF THE JACOBIAN IS AT MOST GTOL IN C ABSOLUTE VALUE. C C INFO = 5 NUMBER OF CALLS TO FCN HAS REACHED OR C EXCEEDED MAXFEV. C C INFO = 6 FTOL IS TOO SMALL. NO FURTHER REDUCTION IN C THE SUM OF SQUARES IS POSSIBLE. C C INFO = 7 XTOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN C THE APPROXIMATE SOLUTION X IS POSSIBLE. C C INFO = 8 GTOL IS TOO SMALL. FVEC IS ORTHOGONAL TO THE C COLUMNS OF THE JACOBIAN TO MACHINE PRECISION. C C NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF C CALLS TO FCN. C C FJAC IS AN OUTPUT M BY N ARRAY. THE UPPER N BY N SUBMATRIX C OF FJAC CONTAINS AN UPPER TRIANGULAR MATRIX R WITH C DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE SUCH THAT C C T T T C P *(JAC *JAC)*P = R *R, C C WHERE P IS A PERMUTATION MATRIX AND JAC IS THE FINAL C CALCULATED JACOBIAN. COLUMN J OF P IS COLUMN IPVT(J) C (SEE BELOW) OF THE IDENTITY MATRIX. THE LOWER TRAPEZOIDAL C PART OF FJAC CONTAINS INFORMATION GENERATED DURING C THE COMPUTATION OF R. C C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. C C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH N. IPVT C DEFINES A PERMUTATION MATRIX P SUCH THAT JAC*P = Q*R, C WHERE JAC IS THE FINAL CALCULATED JACOBIAN, Q IS C ORTHOGONAL (NOT STORED), AND R IS UPPER TRIANGULAR C WITH DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE. C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. C C QTF IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS C THE FIRST N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*FVEC. C C WA1, WA2, AND WA3 ARE WORK ARRAYS OF LENGTH N. C C WA4 IS A WORK ARRAY OF LENGTH M. C C SUBPROGRAMS CALLED C C USER-SUPPLIED ...... FCN C C MINPACK-SUPPLIED ... SPMPAR,ENORM,FDJAC2,LMPAR,QRFAC C C FORTRAN-SUPPLIED ... ABS,AMAX1,AMIN1,SQRT,MOD C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE C C ********** INTEGER I,IFLAG,ITER,J,L REAL ACTRED,DELTA,DIRDER,EPS,FNORM,FNORM1,GNORM,PAR, * PNORM,PRERED,P1,P5,P25,P75,P0001,RATIO,SUM,TEMP,TEMP1, * TEMP2,XNORM REAL SPMPAR,ENORM DATA P1,P5,P25,P75,P0001 * /1.0E-1,5.0E-1,2.5E-1,7.5E-1,1.0E-4/ C C EPS IS THE MACHINE PRECISION. C EPS = SPMPAR(1) C INFO = 0 IFLAG = 0 NFEV = 0 C C CHECK THE INPUT PARAMETERS FOR ERRORS. C IF (N .LE. 0 .OR. M .LT. N .OR. LDFJAC .LT. M * .OR. FTOL .LT. 0.0 .OR. XTOL .LT. 0.0 .OR. GTOL .LT. 0.0 * .OR. MAXFEV .LE. 0 .OR. FACTOR .LE. 0.0) GO TO 300 IF (MODE .NE. 2) GO TO 20 DO 10 J = 1, N IF (DIAG(J) .LE. 0.0) GO TO 300 10 CONTINUE 20 CONTINUE C C EVALUATE THE FUNCTION AT THE STARTING POINT C AND CALCULATE ITS NORM. C IFLAG = 1 CALL FCN(M,N,X,FVEC,IFLAG) NFEV = 1 IF (IFLAG .LT. 0) GO TO 300 FNORM = ENORM(M,FVEC) C C INITIALIZE LEVENBERG-MARQUARDT PARAMETER AND ITERATION COUNTER. C PAR = 0.0 ITER = 1 C C BEGINNING OF THE OUTER LOOP. C 30 CONTINUE C C CALCULATE THE JACOBIAN MATRIX. C IFLAG = 2 CALL FDJAC2(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA4) NFEV = NFEV + N IF (IFLAG .LT. 0) GO TO 300 C C IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES. C IF (NPRINT .LE. 0) GO TO 40 IFLAG = 0 IF (MOD(ITER-1,NPRINT) .EQ. 0) CALL FCN(M,N,X,FVEC,IFLAG) IF (IFLAG .LT. 0) GO TO 300 40 CONTINUE C C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN. C CALL QRFAC(M,N,FJAC,LDFJAC,.TRUE.,IPVT,N,WA1,WA2,WA3) C C ON THE FIRST ITERATION AND IF MODE IS 1, SCALE ACCORDING C TO THE NORMS OF THE COLUMNS OF THE INITIAL JACOBIAN. C IF (ITER .NE. 1) GO TO 80 IF (MODE .EQ. 2) GO TO 60 DO 50 J = 1, N DIAG(J) = WA2(J) IF (WA2(J) .EQ. 0.0) DIAG(J) = 1.0 50 CONTINUE 60 CONTINUE C C ON THE FIRST ITERATION, CALCULATE THE NORM OF THE SCALED X C AND INITIALIZE THE STEP BOUND DELTA. C DO 70 J = 1, N WA3(J) = DIAG(J)*X(J) 70 CONTINUE XNORM = ENORM(N,WA3) DELTA = FACTOR*XNORM IF (DELTA .EQ. 0.0) DELTA = FACTOR 80 CONTINUE C C FORM (Q TRANSPOSE)*FVEC AND STORE THE FIRST N COMPONENTS IN C QTF. C DO 90 I = 1, M WA4(I) = FVEC(I) 90 CONTINUE DO 130 J = 1, N IF (FJAC(J,J) .EQ. 0.0) GO TO 120 SUM = 0.0 DO 100 I = J, M SUM = SUM + FJAC(I,J)*WA4(I) 100 CONTINUE TEMP = -SUM/FJAC(J,J) DO 110 I = J, M WA4(I) = WA4(I) + FJAC(I,J)*TEMP 110 CONTINUE 120 CONTINUE FJAC(J,J) = WA1(J) QTF(J) = WA4(J) 130 CONTINUE C C COMPUTE THE NORM OF THE SCALED GRADIENT. C GNORM = 0.0 IF (FNORM .EQ. 0.0) GO TO 170 DO 160 J = 1, N L = IPVT(J) IF (WA2(L) .EQ. 0.0) GO TO 150 SUM = 0.0 DO 140 I = 1, J SUM = SUM + FJAC(I,J)*(QTF(I)/FNORM) 140 CONTINUE GNORM = AMAX1(GNORM,ABS(SUM/WA2(L))) 150 CONTINUE 160 CONTINUE 170 CONTINUE C C TEST FOR CONVERGENCE OF THE GRADIENT NORM. C IF (GNORM .LE. GTOL) INFO = 4 IF (INFO .NE. 0) GO TO 300 C C RESCALE IF NECESSARY. C IF (MODE .EQ. 2) GO TO 190 DO 180 J = 1, N DIAG(J) = AMAX1(DIAG(J),WA2(J)) 180 CONTINUE 190 CONTINUE C C BEGINNING OF THE INNER LOOP. C 200 CONTINUE C C DETERMINE THE LEVENBERG-MARQUARDT PARAMETER. C CALL LMPAR(N,FJAC,LDFJAC,IPVT,DIAG,QTF,DELTA,PAR,WA1,WA2, * WA3,WA4) C C STORE THE DIRECTION P AND X + P. CALCULATE THE NORM OF P. C DO 210 J = 1, N WA1(J) = -WA1(J) WA2(J) = X(J) + WA1(J) WA3(J) = DIAG(J)*WA1(J) 210 CONTINUE PNORM = ENORM(N,WA3) C C ON THE FIRST ITERATION, ADJUST THE INITIAL STEP BOUND. C IF (ITER .EQ. 1) DELTA = AMIN1(DELTA,PNORM) C C EVALUATE THE FUNCTION AT X + P AND CALCULATE ITS NORM. C IFLAG = 1 CALL FCN(M,N,WA2,WA4,IFLAG) NFEV = NFEV + 1 IF (IFLAG .LT. 0) GO TO 300 FNORM1 = ENORM(M,WA4) C C COMPUTE THE SCALED ACTUAL REDUCTION. C ACTRED = -1.0 IF (P1*FNORM1 .LT. FNORM) ACTRED = 1.0 - (FNORM1/FNORM)**2 C C COMPUTE THE SCALED PREDICTED REDUCTION AND C THE SCALED DIRECTIONAL DERIVATIVE. C DO 230 J = 1, N WA3(J) = 0.0 L = IPVT(J) TEMP = WA1(L) DO 220 I = 1, J WA3(I) = WA3(I) + FJAC(I,J)*TEMP 220 CONTINUE 230 CONTINUE TEMP1 = ENORM(N,WA3)/FNORM TEMP2 = (SQRT(PAR)*PNORM)/FNORM PRERED = TEMP1**2 + TEMP2**2/P5 DIRDER = -(TEMP1**2 + TEMP2**2) C C COMPUTE THE RATIO OF THE ACTUAL TO THE PREDICTED C REDUCTION. C RATIO = 0.0 IF (PRERED .NE. 0.0) RATIO = ACTRED/PRERED C C UPDATE THE STEP BOUND. C IF (RATIO .GT. P25) GO TO 240 IF (ACTRED .GE. 0.0) TEMP = P5 IF (ACTRED .LT. 0.0) * TEMP = P5*DIRDER/(DIRDER + P5*ACTRED) IF (P1*FNORM1 .GE. FNORM .OR. TEMP .LT. P1) TEMP = P1 DELTA = TEMP*AMIN1(DELTA,PNORM/P1) PAR = PAR/TEMP GO TO 260 240 CONTINUE IF (PAR .NE. 0.0 .AND. RATIO .LT. P75) GO TO 250 DELTA = PNORM/P5 PAR = P5*PAR 250 CONTINUE 260 CONTINUE C C TEST FOR SUCCESSFUL ITERATION. C IF (RATIO .LT. P0001) GO TO 290 C C SUCCESSFUL ITERATION. UPDATE X, FVEC, AND THEIR NORMS. C DO 270 J = 1, N X(J) = WA2(J) WA2(J) = DIAG(J)*X(J) 270 CONTINUE DO 280 I = 1, M FVEC(I) = WA4(I) 280 CONTINUE XNORM = ENORM(N,WA2) FNORM = FNORM1 ITER = ITER + 1 290 CONTINUE C C TESTS FOR CONVERGENCE. C IF (ABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL * .AND. P5*RATIO .LE. 1.0) INFO = 1 IF (DELTA .LE. XTOL*XNORM) INFO = 2 IF (ABS(ACTRED) .LE. FTOL .AND. PRERED .LE. FTOL * .AND. P5*RATIO .LE. 1.0 .AND. INFO .EQ. 2) INFO = 3 IF (INFO .NE. 0) GO TO 300 C C TESTS FOR TERMINATION AND STRINGENT TOLERANCES. C IF (NFEV .GE. MAXFEV) INFO = 5 IF (ABS(ACTRED) .LE. EPS .AND. PRERED .LE. EPS * .AND. P5*RATIO .LE. 1.0) INFO = 6 IF (DELTA .LE. EPS*XNORM) INFO = 7 IF (GNORM .LE. EPS) INFO = 8 IF (INFO .NE. 0) GO TO 300 C C END OF THE INNER LOOP. REPEAT IF ITERATION UNSUCCESSFUL. C IF (RATIO .LT. P0001) GO TO 200 C C END OF THE OUTER LOOP. C GO TO 30 300 CONTINUE C C TERMINATION, EITHER NORMAL OR USER IMPOSED. C IF (IFLAG .LT. 0) INFO = IFLAG IFLAG = 0 IF (NPRINT .GT. 0) CALL FCN(M,N,X,FVEC,IFLAG) RETURN END REAL FUNCTION ENORM(N,X) INTEGER N REAL X(N) C ********** C C FUNCTION ENORM C C GIVEN AN N-VECTOR X, THIS FUNCTION CALCULATES THE C EUCLIDEAN NORM OF X. C C THE EUCLIDEAN NORM IS COMPUTED BY ACCUMULATING THE SUM OF C SQUARES IN THREE DIFFERENT SUMS. THE SUMS OF SQUARES FOR THE C SMALL AND LARGE COMPONENTS ARE SCALED SO THAT NO OVERFLOWS C OCCUR. NON-DESTRUCTIVE UNDERFLOWS ARE PERMITTED. UNDERFLOWS C AND OVERFLOWS DO NOT OCCUR IN THE COMPUTATION OF THE UNSCALED C SUM OF SQUARES FOR THE INTERMEDIATE COMPONENTS. C THE DEFINITIONS OF SMALL, INTERMEDIATE AND LARGE COMPONENTS C DEPEND ON TWO CONSTANTS, RDWARF AND RGIANT. THE MAIN C RESTRICTIONS ON THESE CONSTANTS ARE THAT RDWARF**2 NOT C UNDERFLOW AND RGIANT**2 NOT OVERFLOW. THE CONSTANTS C GIVEN HERE ARE SUITABLE FOR EVERY KNOWN COMPUTER. C C THE FUNCTION STATEMENT IS C C REAL FUNCTION ENORM(N,X) C C WHERE C C N IS A POSITIVE INTEGER INPUT VARIABLE. C C X IS AN INPUT ARRAY OF LENGTH N. C C SUBPROGRAMS CALLED C C FORTRAN-SUPPLIED ... ABS,SQRT C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE C C ********** INTEGER I REAL AGIANT,FLOATN,RDWARF,RGIANT,S1,S2,S3,XABS,X1MAX,X3MAX DATA RDWARF,RGIANT /3.834E-20,1.304E19/ C S1 = 0.0 S2 = 0.0 S3 = 0.0 X1MAX = 0.0 X3MAX = 0.0 FLOATN = N AGIANT = RGIANT/FLOATN DO 90 I = 1, N XABS = ABS(X(I)) IF (XABS .GT. RDWARF .AND. XABS .LT. AGIANT) GO TO 70 IF (XABS .LE. RDWARF) GO TO 30 C C SUM FOR LARGE COMPONENTS. C IF (XABS .LE. X1MAX) GO TO 10 S1 = 1.0 + S1*(X1MAX/XABS)**2 X1MAX = XABS GO TO 20 10 CONTINUE S1 = S1 + (XABS/X1MAX)**2 20 CONTINUE GO TO 60 30 CONTINUE C C SUM FOR SMALL COMPONENTS. C IF (XABS .LE. X3MAX) GO TO 40 S3 = 1.0 + S3*(X3MAX/XABS)**2 X3MAX = XABS GO TO 50 40 CONTINUE IF (XABS .NE. 0.0) S3 = S3 + (XABS/X3MAX)**2 50 CONTINUE 60 CONTINUE GO TO 80 70 CONTINUE C C SUM FOR INTERMEDIATE COMPONENTS. C S2 = S2 + XABS**2 80 CONTINUE 90 CONTINUE C C CALCULATION OF NORM. C IF (S1 .EQ. 0.0) GO TO 100 ENORM = X1MAX*SQRT(S1 + (S2/X1MAX)/X1MAX) GO TO 130 100 CONTINUE IF (S2 .EQ. 0.0) GO TO 110 IF (S2 .GE. X3MAX) * ENORM = SQRT(S2*(1.0 + (X3MAX/S2)*(X3MAX*S3))) IF (S2 .LT. X3MAX) * ENORM = SQRT(X3MAX*((S2/X3MAX) + (X3MAX*S3))) GO TO 120 110 CONTINUE ENORM = X3MAX*SQRT(S3) 120 CONTINUE 130 CONTINUE RETURN END SUBROUTINE DOGLEG(N,R,LR,DIAG,QTB,DELTA,X,WA1,WA2) INTEGER N,LR REAL DELTA REAL R(LR),DIAG(N),QTB(N),X(N),WA1(N),WA2(N) C ********** C C SUBROUTINE DOGLEG C C GIVEN AN M BY N MATRIX A, AN N BY N NONSINGULAR DIAGONAL C MATRIX D, AN M-VECTOR B, AND A POSITIVE NUMBER DELTA, THE C PROBLEM IS TO DETERMINE THE CONVEX COMBINATION X OF THE C GAUSS-NEWTON AND SCALED GRADIENT DIRECTIONS THAT MINIMIZES C (A*X - B) IN THE LEAST SQUARES SENSE, SUBJECT TO THE C RESTRICTION THAT THE EUCLIDEAN NORM OF D*X BE AT MOST DELTA. C C THIS SUBROUTINE COMPLETES THE SOLUTION OF THE PROBLEM C IF IT IS PROVIDED WITH THE NECESSARY INFORMATION FROM THE C QR FACTORIZATION OF A. THAT IS, IF A = Q*R, WHERE Q HAS C ORTHOGONAL COLUMNS AND R IS AN UPPER TRIANGULAR MATRIX, C THEN DOGLEG EXPECTS THE FULL UPPER TRIANGLE OF R AND C THE FIRST N COMPONENTS OF (Q TRANSPOSE)*B. C C THE SUBROUTINE STATEMENT IS C C SUBROUTINE DOGLEG(N,R,LR,DIAG,QTB,DELTA,X,WA1,WA2) C C WHERE C C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE ORDER OF R. C C R IS AN INPUT ARRAY OF LENGTH LR WHICH MUST CONTAIN THE UPPER C TRIANGULAR MATRIX R STORED BY ROWS. C C LR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN C (N*(N+1))/2. C C DIAG IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE C DIAGONAL ELEMENTS OF THE MATRIX D. C C QTB IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE FIRST C N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*B. C C DELTA IS A POSITIVE INPUT VARIABLE WHICH SPECIFIES AN UPPER C BOUND ON THE EUCLIDEAN NORM OF D*X. C C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE DESIRED C CONVEX COMBINATION OF THE GAUSS-NEWTON DIRECTION AND THE C SCALED GRADIENT DIRECTION. C C WA1 AND WA2 ARE WORK ARRAYS OF LENGTH N. C C SUBPROGRAMS CALLED C C MINPACK-SUPPLIED ... SPMPAR,ENORM C C FORTRAN-SUPPLIED ... ABS,AMAX1,AMIN1,SQRT C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE C C ********** INTEGER I,J,JJ,JP1,K,L REAL ALPHA,BNORM,EPSMCH,GNORM,QNORM,SGNORM,SUM,TEMP REAL SPMPAR,ENORM C C EPSMCH IS THE MACHINE PRECISION. C EPSMCH = SPMPAR(1) C C FIRST, CALCULATE THE GAUSS-NEWTON DIRECTION. C JJ = (N*(N + 1))/2 + 1 DO 50 K = 1, N J = N - K + 1 JP1 = J + 1 JJ = JJ - K L = JJ + 1 SUM = 0.0 IF (N .LT. JP1) GO TO 20 DO 10 I = JP1, N SUM = SUM + R(L)*X(I) L = L + 1 10 CONTINUE 20 CONTINUE TEMP = R(JJ) IF (TEMP .NE. 0.0) GO TO 40 L = J DO 30 I = 1, J TEMP = AMAX1(TEMP,ABS(R(L))) L = L + N - I 30 CONTINUE TEMP = EPSMCH*TEMP IF (TEMP .EQ. 0.0) TEMP = EPSMCH 40 CONTINUE X(J) = (QTB(J) - SUM)/TEMP 50 CONTINUE C C TEST WHETHER THE GAUSS-NEWTON DIRECTION IS ACCEPTABLE. C DO 60 J = 1, N WA1(J) = 0.0 WA2(J) = DIAG(J)*X(J) 60 CONTINUE QNORM = ENORM(N,WA2) IF (QNORM .LE. DELTA) GO TO 140 C C THE GAUSS-NEWTON DIRECTION IS NOT ACCEPTABLE. C NEXT, CALCULATE THE SCALED GRADIENT DIRECTION. C L = 1 DO 80 J = 1, N TEMP = QTB(J) DO 70 I = J, N WA1(I) = WA1(I) + R(L)*TEMP L = L + 1 70 CONTINUE WA1(J) = WA1(J)/DIAG(J) 80 CONTINUE C C CALCULATE THE NORM OF THE SCALED GRADIENT AND TEST FOR C THE SPECIAL CASE IN WHICH THE SCALED GRADIENT IS ZERO. C GNORM = ENORM(N,WA1) SGNORM = 0.0 ALPHA = DELTA/QNORM IF (GNORM .EQ. 0.0) GO TO 120 C C CALCULATE THE POINT ALONG THE SCALED GRADIENT C AT WHICH THE QUADRATIC IS MINIMIZED. C DO 90 J = 1, N WA1(J) = (WA1(J)/GNORM)/DIAG(J) 90 CONTINUE L = 1 DO 110 J = 1, N SUM = 0.0 DO 100 I = J, N SUM = SUM + R(L)*WA1(I) L = L + 1 100 CONTINUE WA2(J) = SUM 110 CONTINUE TEMP = ENORM(N,WA2) SGNORM = (GNORM/TEMP)/TEMP C C TEST WHETHER THE SCALED GRADIENT DIRECTION IS ACCEPTABLE. C ALPHA = 0.0 IF (SGNORM .GE. DELTA) GO TO 120 C C THE SCALED GRADIENT DIRECTION IS NOT ACCEPTABLE. C FINALLY, CALCULATE THE POINT ALONG THE DOGLEG C AT WHICH THE QUADRATIC IS MINIMIZED. C BNORM = ENORM(N,QTB) TEMP = (BNORM/GNORM)*(BNORM/QNORM)*(SGNORM/DELTA) TEMP = TEMP - (DELTA/QNORM)*(SGNORM/DELTA)**2 * + SQRT((TEMP-(DELTA/QNORM))**2 * +(1.0-(DELTA/QNORM)**2)*(1.0-(SGNORM/DELTA)**2)) ALPHA = ((DELTA/QNORM)*(1.0 - (SGNORM/DELTA)**2))/TEMP 120 CONTINUE C C FORM APPROPRIATE CONVEX COMBINATION OF THE GAUSS-NEWTON C DIRECTION AND THE SCALED GRADIENT DIRECTION. C TEMP = (1.0 - ALPHA)*AMIN1(SGNORM,DELTA) DO 130 J = 1, N X(J) = TEMP*WA1(J) + ALPHA*X(J) 130 CONTINUE 140 CONTINUE RETURN END SUBROUTINE FDJAC1(FCN,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,EPSFCN, * WA1,WA2) INTEGER N,LDFJAC,IFLAG,ML,MU REAL EPSFCN REAL X(N),FVEC(N),FJAC(LDFJAC,N),WA1(N),WA2(N) EXTERNAL FCN C ********** C C SUBROUTINE FDJAC1 C C THIS SUBROUTINE COMPUTES A FORWARD-DIFFERENCE APPROXIMATION C TO THE N BY N JACOBIAN MATRIX ASSOCIATED WITH A SPECIFIED C PROBLEM OF N FUNCTIONS IN N VARIABLES. IF THE JACOBIAN HAS C A BANDED FORM, THEN FUNCTION EVALUATIONS ARE SAVED BY ONLY C APPROXIMATING THE NONZERO TERMS. C C THE SUBROUTINE STATEMENT IS C C SUBROUTINE FDJAC1(FCN,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,EPSFCN, C WA1,WA2) C C WHERE C C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH C CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED C IN AN EXTERNAL STATEMENT IN THE USER CALLING C PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. C C SUBROUTINE FCN(N,X,FVEC,IFLAG) C INTEGER N,IFLAG C REAL X(N),FVEC(N) C ---------- C CALCULATE THE FUNCTIONS AT X AND C RETURN THIS VECTOR IN FVEC. C ---------- C RETURN C END C C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS C THE USER WANTS TO TERMINATE EXECUTION OF FDJAC1. C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. C C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER C OF FUNCTIONS AND VARIABLES. C C X IS AN INPUT ARRAY OF LENGTH N. C C FVEC IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE C FUNCTIONS EVALUATED AT X. C C FJAC IS AN OUTPUT N BY N ARRAY WHICH CONTAINS THE C APPROXIMATION TO THE JACOBIAN MATRIX EVALUATED AT X. C C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. C C IFLAG IS AN INTEGER VARIABLE WHICH CAN BE USED TO TERMINATE C THE EXECUTION OF FDJAC1. SEE DESCRIPTION OF FCN. C C ML IS A NONNEGATIVE INTEGER INPUT VARIABLE WHICH SPECIFIES C THE NUMBER OF SUBDIAGONALS WITHIN THE BAND OF THE C JACOBIAN MATRIX. IF THE JACOBIAN IS NOT BANDED, SET C ML TO AT LEAST N - 1. C C EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE C STEP LENGTH FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS C APPROXIMATION ASSUMES THAT THE RELATIVE ERRORS IN THE C FUNCTIONS ARE OF THE ORDER OF EPSFCN. IF EPSFCN IS LESS C THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE RELATIVE C ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE C PRECISION. C C MU IS A NONNEGATIVE INTEGER INPUT VARIABLE WHICH SPECIFIES C THE NUMBER OF SUPERDIAGONALS WITHIN THE BAND OF THE C JACOBIAN MATRIX. IF THE JACOBIAN IS NOT BANDED, SET C MU TO AT LEAST N - 1. C C WA1 AND WA2 ARE WORK ARRAYS OF LENGTH N. IF ML + MU + 1 IS AT C LEAST N, THEN THE JACOBIAN IS CONSIDERED DENSE, AND WA2 IS C NOT REFERENCED. C C SUBPROGRAMS CALLED C C MINPACK-SUPPLIED ... SPMPAR C C FORTRAN-SUPPLIED ... ABS,AMAX1,SQRT C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE C C ********** INTEGER I,J,K,MSUM REAL EPS,EPSMCH,H,TEMP,ZERO REAL SPMPAR DATA ZERO /0.0E0/ C C EPSMCH IS THE MACHINE PRECISION. C EPSMCH = SPMPAR(1) C EPS = SQRT(AMAX1(EPSFCN,EPSMCH)) MSUM = ML + MU + 1 IF (MSUM .LT. N) GO TO 40 C C COMPUTATION OF DENSE APPROXIMATE JACOBIAN. C DO 20 J = 1, N TEMP = X(J) H = EPS*ABS(TEMP) IF (H .EQ. ZERO) H = EPS X(J) = TEMP + H CALL FCN(N,X,WA1,IFLAG) IF (IFLAG .LT. 0) GO TO 30 X(J) = TEMP DO 10 I = 1, N FJAC(I,J) = (WA1(I) - FVEC(I))/H 10 CONTINUE 20 CONTINUE 30 CONTINUE GO TO 110 40 CONTINUE C C COMPUTATION OF BANDED APPROXIMATE JACOBIAN. C DO 90 K = 1, MSUM DO 60 J = K, N, MSUM WA2(J) = X(J) H = EPS*ABS(WA2(J)) IF (H .EQ. ZERO) H = EPS X(J) = WA2(J) + H 60 CONTINUE CALL FCN(N,X,WA1,IFLAG) IF (IFLAG .LT. 0) GO TO 100 DO 80 J = K, N, MSUM X(J) = WA2(J) H = EPS*ABS(WA2(J)) IF (H .EQ. ZERO) H = EPS DO 70 I = 1, N FJAC(I,J) = ZERO IF (I .GE. J - MU .AND. I .LE. J + ML) * FJAC(I,J) = (WA1(I) - FVEC(I))/H 70 CONTINUE 80 CONTINUE 90 CONTINUE 100 CONTINUE 110 CONTINUE RETURN C C LAST CARD OF SUBROUTINE FDJAC1. C END SUBROUTINE FDJAC2(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA) INTEGER M,N,LDFJAC,IFLAG REAL EPSFCN REAL X(N),FVEC(M),FJAC(LDFJAC,N),WA(M) EXTERNAL FCN C ********** C C SUBROUTINE FDJAC2 C C THIS SUBROUTINE COMPUTES A FORWARD-DIFFERENCE APPROXIMATION C TO THE M BY N JACOBIAN MATRIX ASSOCIATED WITH A SPECIFIED C PROBLEM OF M FUNCTIONS IN N VARIABLES. C C THE SUBROUTINE STATEMENT IS C C SUBROUTINE FDJAC2(FCN,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,EPSFCN,WA) C C WHERE C C FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE WHICH C CALCULATES THE FUNCTIONS. FCN MUST BE DECLARED C IN AN EXTERNAL STATEMENT IN THE USER CALLING C PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS. C C SUBROUTINE FCN(M,N,X,FVEC,IFLAG) C INTEGER M,N,IFLAG C REAL X(N),FVEC(M) C ---------- C CALCULATE THE FUNCTIONS AT X AND C RETURN THIS VECTOR IN FVEC. C ---------- C RETURN C END C C THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS C THE USER WANTS TO TERMINATE EXECUTION OF FDJAC2. C IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER. C C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER C OF FUNCTIONS. C C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER C OF VARIABLES. N MUST NOT EXCEED M. C C X IS AN INPUT ARRAY OF LENGTH N. C C FVEC IS AN INPUT ARRAY OF LENGTH M WHICH MUST CONTAIN THE C FUNCTIONS EVALUATED AT X. C C FJAC IS AN OUTPUT M BY N ARRAY WHICH CONTAINS THE C APPROXIMATION TO THE JACOBIAN MATRIX EVALUATED AT X. C C LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC. C C IFLAG IS AN INTEGER VARIABLE WHICH CAN BE USED TO TERMINATE C THE EXECUTION OF FDJAC2. SEE DESCRIPTION OF FCN. C C EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE C STEP LENGTH FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS C APPROXIMATION ASSUMES THAT THE RELATIVE ERRORS IN THE C FUNCTIONS ARE OF THE ORDER OF EPSFCN. IF EPSFCN IS LESS C THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE RELATIVE C ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE C PRECISION. C C WA IS A WORK ARRAY OF LENGTH M. C C SUBPROGRAMS CALLED C C USER-SUPPLIED ...... FCN C C MINPACK-SUPPLIED ... SPMPAR C C FORTRAN-SUPPLIED ... ABS,AMAX1,SQRT C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE C C ********** INTEGER I,J REAL EPS,EPSMCH,H,TEMP,ZERO REAL SPMPAR DATA ZERO /0.0E0/ C C EPSMCH IS THE MACHINE PRECISION. C EPSMCH = SPMPAR(1) C EPS = SQRT(AMAX1(EPSFCN,EPSMCH)) DO 20 J = 1, N TEMP = X(J) H = EPS*ABS(TEMP) IF (H .EQ. ZERO) H = EPS X(J) = TEMP + H CALL FCN(M,N,X,WA,IFLAG) IF (IFLAG .LT. 0) GO TO 30 X(J) = TEMP DO 10 I = 1, M FJAC(I,J) = (WA(I) - FVEC(I))/H 10 CONTINUE 20 CONTINUE 30 CONTINUE RETURN C C LAST CARD OF SUBROUTINE FDJAC2. C END SUBROUTINE LMPAR(N,R,LDR,IPVT,DIAG,QTB,DELTA,PAR,X,SDIAG,WA1, * WA2) INTEGER N,LDR INTEGER IPVT(N) REAL DELTA,PAR REAL R(LDR,N),DIAG(N),QTB(N),X(N),SDIAG(N),WA1(N),WA2(N) C ********** C C SUBROUTINE LMPAR C C GIVEN AN M BY N MATRIX A, AN N BY N NONSINGULAR DIAGONAL C MATRIX D, AN M-VECTOR B, AND A POSITIVE NUMBER DELTA, C THE PROBLEM IS TO DETERMINE A VALUE FOR THE PARAMETER C PAR SUCH THAT IF X SOLVES THE SYSTEM C C A*X = B , SQRT(PAR)*D*X = 0 , C C IN THE LEAST SQUARES SENSE, AND DXNORM IS THE EUCLIDEAN C NORM OF D*X, THEN EITHER PAR IS ZERO AND C C (DXNORM-DELTA) .LE. 0.1*DELTA , C C OR PAR IS POSITIVE AND C C ABS(DXNORM-DELTA) .LE. 0.1*DELTA . C C THIS SUBROUTINE COMPLETES THE SOLUTION OF THE PROBLEM C IF IT IS PROVIDED WITH THE NECESSARY INFORMATION FROM THE C QR FACTORIZATION, WITH COLUMN PIVOTING, OF A. THAT IS, IF C A*P = Q*R, WHERE P IS A PERMUTATION MATRIX, Q HAS ORTHOGONAL C COLUMNS, AND R IS AN UPPER TRIANGULAR MATRIX WITH DIAGONAL C ELEMENTS OF NONINCREASING MAGNITUDE, THEN LMPAR EXPECTS C THE FULL UPPER TRIANGLE OF R, THE PERMUTATION MATRIX P, C AND THE FIRST N COMPONENTS OF (Q TRANSPOSE)*B. ON OUTPUT C LMPAR ALSO PROVIDES AN UPPER TRIANGULAR MATRIX S SUCH THAT C C T T T C P *(A *A + PAR*D*D)*P = S *S . C C S IS EMPLOYED WITHIN LMPAR AND MAY BE OF SEPARATE INTEREST. C C ONLY A FEW ITERATIONS ARE GENERALLY NEEDED FOR CONVERGENCE C OF THE ALGORITHM. IF, HOWEVER, THE LIMIT OF 10 ITERATIONS C IS REACHED, THEN THE OUTPUT PAR WILL CONTAIN THE BEST C VALUE OBTAINED SO FAR. C C THE SUBROUTINE STATEMENT IS C C SUBROUTINE LMPAR(N,R,LDR,IPVT,DIAG,QTB,DELTA,PAR,X,SDIAG, C WA1,WA2) C C WHERE C C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE ORDER OF R. C C R IS AN N BY N ARRAY. ON INPUT THE FULL UPPER TRIANGLE C MUST CONTAIN THE FULL UPPER TRIANGLE OF THE MATRIX R. C ON OUTPUT THE FULL UPPER TRIANGLE IS UNALTERED, AND THE C STRICT LOWER TRIANGLE CONTAINS THE STRICT UPPER TRIANGLE C (TRANSPOSED) OF THE UPPER TRIANGULAR MATRIX S. C C LDR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY R. C C IPVT IS AN INTEGER INPUT ARRAY OF LENGTH N WHICH DEFINES THE C PERMUTATION MATRIX P SUCH THAT A*P = Q*R. COLUMN J OF P C IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. C C DIAG IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE C DIAGONAL ELEMENTS OF THE MATRIX D. C C QTB IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE FIRST C N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*B. C C DELTA IS A POSITIVE INPUT VARIABLE WHICH SPECIFIES AN UPPER C BOUND ON THE EUCLIDEAN NORM OF D*X. C C PAR IS A NONNEGATIVE VARIABLE. ON INPUT PAR CONTAINS AN C INITIAL ESTIMATE OF THE LEVENBERG-MARQUARDT PARAMETER. C ON OUTPUT PAR CONTAINS THE FINAL ESTIMATE. C C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE LEAST C SQUARES SOLUTION OF THE SYSTEM A*X = B, SQRT(PAR)*D*X = 0, C FOR THE OUTPUT PAR. C C SDIAG IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE C DIAGONAL ELEMENTS OF THE UPPER TRIANGULAR MATRIX S. C C WA1 AND WA2 ARE WORK ARRAYS OF LENGTH N. C C SUBPROGRAMS CALLED C C MINPACK-SUPPLIED ... SPMPAR,ENORM,QRSOLV C C FORTRAN-SUPPLIED ... ABS,AMAX1,AMIN1,SQRT C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE C C ********** INTEGER I,ITER,J,JM1,JP1,K,L,NSING REAL DXNORM,DWARF,FP,GNORM,PARC,PARL,PARU,P1,P001,SUM,TEMP,ZERO REAL SPMPAR,ENORM DATA P1,P001,ZERO /1.0E-1,1.0E-3,0.0E0/ C C DWARF IS THE SMALLEST POSITIVE MAGNITUDE. C DWARF = SPMPAR(2) C C COMPUTE AND STORE IN X THE GAUSS-NEWTON DIRECTION. IF THE C JACOBIAN IS RANK-DEFICIENT, OBTAIN A LEAST SQUARES SOLUTION. C NSING = N DO 10 J = 1, N WA1(J) = QTB(J) IF (R(J,J) .EQ. ZERO .AND. NSING .EQ. N) NSING = J - 1 IF (NSING .LT. N) WA1(J) = ZERO 10 CONTINUE IF (NSING .LT. 1) GO TO 50 DO 40 K = 1, NSING J = NSING - K + 1 WA1(J) = WA1(J)/R(J,J) TEMP = WA1(J) JM1 = J - 1 IF (JM1 .LT. 1) GO TO 30 DO 20 I = 1, JM1 WA1(I) = WA1(I) - R(I,J)*TEMP 20 CONTINUE 30 CONTINUE 40 CONTINUE 50 CONTINUE DO 60 J = 1, N L = IPVT(J) X(L) = WA1(J) 60 CONTINUE C C INITIALIZE THE ITERATION COUNTER. C EVALUATE THE FUNCTION AT THE ORIGIN, AND TEST C FOR ACCEPTANCE OF THE GAUSS-NEWTON DIRECTION. C ITER = 0 DO 70 J = 1, N WA2(J) = DIAG(J)*X(J) 70 CONTINUE DXNORM = ENORM(N,WA2) FP = DXNORM - DELTA IF (FP .LE. P1*DELTA) GO TO 220 C C IF THE JACOBIAN IS NOT RANK DEFICIENT, THE NEWTON C STEP PROVIDES A LOWER BOUND, PARL, FOR THE ZERO OF C THE FUNCTION. OTHERWISE SET THIS BOUND TO ZERO. C PARL = ZERO IF (NSING .LT. N) GO TO 120 DO 80 J = 1, N L = IPVT(J) WA1(J) = DIAG(L)*(WA2(L)/DXNORM) 80 CONTINUE DO 110 J = 1, N SUM = ZERO JM1 = J - 1 IF (JM1 .LT. 1) GO TO 100 DO 90 I = 1, JM1 SUM = SUM + R(I,J)*WA1(I) 90 CONTINUE 100 CONTINUE WA1(J) = (WA1(J) - SUM)/R(J,J) 110 CONTINUE TEMP = ENORM(N,WA1) PARL = ((FP/DELTA)/TEMP)/TEMP 120 CONTINUE C C CALCULATE AN UPPER BOUND, PARU, FOR THE ZERO OF THE FUNCTION. C DO 140 J = 1, N SUM = ZERO DO 130 I = 1, J SUM = SUM + R(I,J)*QTB(I) 130 CONTINUE L = IPVT(J) WA1(J) = SUM/DIAG(L) 140 CONTINUE GNORM = ENORM(N,WA1) PARU = GNORM/DELTA IF (PARU .EQ. ZERO) PARU = DWARF/AMIN1(DELTA,P1) C C IF THE INPUT PAR LIES OUTSIDE OF THE INTERVAL (PARL,PARU), C SET PAR TO THE CLOSER ENDPOINT. C PAR = AMAX1(PAR,PARL) PAR = AMIN1(PAR,PARU) IF (PAR .EQ. ZERO) PAR = GNORM/DXNORM C C BEGINNING OF AN ITERATION. C 150 CONTINUE ITER = ITER + 1 C C EVALUATE THE FUNCTION AT THE CURRENT VALUE OF PAR. C IF (PAR .EQ. ZERO) PAR = AMAX1(DWARF,P001*PARU) TEMP = SQRT(PAR) DO 160 J = 1, N WA1(J) = TEMP*DIAG(J) 160 CONTINUE CALL QRSOLV(N,R,LDR,IPVT,WA1,QTB,X,SDIAG,WA2) DO 170 J = 1, N WA2(J) = DIAG(J)*X(J) 170 CONTINUE DXNORM = ENORM(N,WA2) TEMP = FP FP = DXNORM - DELTA C C IF THE FUNCTION IS SMALL ENOUGH, ACCEPT THE CURRENT VALUE C OF PAR. ALSO TEST FOR THE EXCEPTIONAL CASES WHERE PARL C IS ZERO OR THE NUMBER OF ITERATIONS HAS REACHED 10. C IF (ABS(FP) .LE. P1*DELTA * .OR. PARL .EQ. ZERO .AND. FP .LE. TEMP * .AND. TEMP .LT. ZERO .OR. ITER .EQ. 10) GO TO 220 C C COMPUTE THE NEWTON CORRECTION. C DO 180 J = 1, N L = IPVT(J) WA1(J) = DIAG(L)*(WA2(L)/DXNORM) 180 CONTINUE DO 210 J = 1, N WA1(J) = WA1(J)/SDIAG(J) TEMP = WA1(J) JP1 = J + 1 IF (N .LT. JP1) GO TO 200 DO 190 I = JP1, N WA1(I) = WA1(I) - R(I,J)*TEMP 190 CONTINUE 200 CONTINUE 210 CONTINUE TEMP = ENORM(N,WA1) PARC = ((FP/DELTA)/TEMP)/TEMP C C DEPENDING ON THE SIGN OF THE FUNCTION, UPDATE PARL OR PARU. C IF (FP .GT. ZERO) PARL = AMAX1(PARL,PAR) IF (FP .LT. ZERO) PARU = AMIN1(PARU,PAR) C C COMPUTE AN IMPROVED ESTIMATE FOR PAR. C PAR = AMAX1(PARL,PAR+PARC) C C END OF AN ITERATION. C GO TO 150 220 CONTINUE C C TERMINATION. C IF (ITER .EQ. 0) PAR = ZERO RETURN C C LAST CARD OF SUBROUTINE LMPAR. C END SUBROUTINE QFORM(M,N,Q,LDQ,WA) INTEGER M,N,LDQ REAL Q(LDQ,M),WA(M) C ********** C C SUBROUTINE QFORM C C THIS SUBROUTINE PROCEEDS FROM THE COMPUTED QR FACTORIZATION OF C AN M BY N MATRIX A TO ACCUMULATE THE M BY M ORTHOGONAL MATRIX C Q FROM ITS FACTORED FORM. C C THE SUBROUTINE STATEMENT IS C C SUBROUTINE QFORM(M,N,Q,LDQ,WA) C C WHERE C C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER C OF ROWS OF A AND THE ORDER OF Q. C C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER C OF COLUMNS OF A. C C Q IS AN M BY M ARRAY. ON INPUT THE FULL LOWER TRAPEZOID IN C THE FIRST MIN(M,N) COLUMNS OF Q CONTAINS THE FACTORED FORM. C ON OUTPUT Q HAS BEEN ACCUMULATED INTO A SQUARE MATRIX. C C LDQ IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY Q. C C WA IS A WORK ARRAY OF LENGTH M. C C SUBPROGRAMS CALLED C C FORTRAN-SUPPLIED ... MIN0 C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE C C ********** INTEGER I,J,JM1,K,L,MINMN,NP1 REAL ONE,SUM,TEMP,ZERO DATA ONE,ZERO /1.0E0,0.0E0/ C C ZERO OUT UPPER TRIANGLE OF Q IN THE FIRST MIN(M,N) COLUMNS. C MINMN = MIN0(M,N) IF (MINMN .LT. 2) GO TO 30 DO 20 J = 2, MINMN JM1 = J - 1 DO 10 I = 1, JM1 Q(I,J) = ZERO 10 CONTINUE 20 CONTINUE 30 CONTINUE C C INITIALIZE REMAINING COLUMNS TO THOSE OF THE IDENTITY MATRIX. C NP1 = N + 1 IF (M .LT. NP1) GO TO 60 DO 50 J = NP1, M DO 40 I = 1, M Q(I,J) = ZERO 40 CONTINUE Q(J,J) = ONE 50 CONTINUE 60 CONTINUE C C ACCUMULATE Q FROM ITS FACTORED FORM. C DO 120 L = 1, MINMN K = MINMN - L + 1 DO 70 I = K, M WA(I) = Q(I,K) Q(I,K) = ZERO 70 CONTINUE Q(K,K) = ONE IF (WA(K) .EQ. ZERO) GO TO 110 DO 100 J = K, M SUM = ZERO DO 80 I = K, M SUM = SUM + Q(I,J)*WA(I) 80 CONTINUE TEMP = SUM/WA(K) DO 90 I = K, M Q(I,J) = Q(I,J) - TEMP*WA(I) 90 CONTINUE 100 CONTINUE 110 CONTINUE 120 CONTINUE RETURN C C LAST CARD OF SUBROUTINE QFORM. C END SUBROUTINE QRFAC(M,N,A,LDA,PIVOT,IPVT,LIPVT,RDIAG,ACNORM,WA) INTEGER M,N,LDA,LIPVT INTEGER IPVT(LIPVT) LOGICAL PIVOT REAL A(LDA,N),RDIAG(N),ACNORM(N),WA(N) C ********** C C SUBROUTINE QRFAC C C THIS SUBROUTINE USES HOUSEHOLDER TRANSFORMATIONS WITH COLUMN C PIVOTING (OPTIONAL) TO COMPUTE A QR FACTORIZATION OF THE C M BY N MATRIX A. THAT IS, QRFAC DETERMINES AN ORTHOGONAL C MATRIX Q, A PERMUTATION MATRIX P, AND AN UPPER TRAPEZOIDAL C MATRIX R WITH DIAGONAL ELEMENTS OF NONINCREASING MAGNITUDE, C SUCH THAT A*P = Q*R. THE HOUSEHOLDER TRANSFORMATION FOR C COLUMN K, K = 1,2,...,MIN(M,N), IS OF THE FORM C C T C I - (1/U(K))*U*U C C WHERE U HAS ZEROS IN THE FIRST K-1 POSITIONS. THE FORM OF C THIS TRANSFORMATION AND THE METHOD OF PIVOTING FIRST C APPEARED IN THE CORRESPONDING LINPACK SUBROUTINE. C C THE SUBROUTINE STATEMENT IS C C SUBROUTINE QRFAC(M,N,A,LDA,PIVOT,IPVT,LIPVT,RDIAG,ACNORM,WA) C C WHERE C C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER C OF ROWS OF A. C C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER C OF COLUMNS OF A. C C A IS AN M BY N ARRAY. ON INPUT A CONTAINS THE MATRIX FOR C WHICH THE QR FACTORIZATION IS TO BE COMPUTED. ON OUTPUT C THE STRICT UPPER TRAPEZOIDAL PART OF A CONTAINS THE STRICT C UPPER TRAPEZOIDAL PART OF R, AND THE LOWER TRAPEZOIDAL C PART OF A CONTAINS A FACTORED FORM OF Q (THE NON-TRIVIAL C ELEMENTS OF THE U VECTORS DESCRIBED ABOVE). C C LDA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY A. C C PIVOT IS A LOGICAL INPUT VARIABLE. IF PIVOT IS SET TRUE, C THEN COLUMN PIVOTING IS ENFORCED. IF PIVOT IS SET FALSE, C THEN NO COLUMN PIVOTING IS DONE. C C IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH LIPVT. IPVT C DEFINES THE PERMUTATION MATRIX P SUCH THAT A*P = Q*R. C COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. C IF PIVOT IS FALSE, IPVT IS NOT REFERENCED. C C LIPVT IS A POSITIVE INTEGER INPUT VARIABLE. IF PIVOT IS FALSE, C THEN LIPVT MAY BE AS SMALL AS 1. IF PIVOT IS TRUE, THEN C LIPVT MUST BE AT LEAST N. C C RDIAG IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE C DIAGONAL ELEMENTS OF R. C C ACNORM IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE C NORMS OF THE CORRESPONDING COLUMNS OF THE INPUT MATRIX A. C IF THIS INFORMATION IS NOT NEEDED, THEN ACNORM CAN COINCIDE C WITH RDIAG. C C WA IS A WORK ARRAY OF LENGTH N. IF PIVOT IS FALSE, THEN WA C CAN COINCIDE WITH RDIAG. C C SUBPROGRAMS CALLED C C MINPACK-SUPPLIED ... SPMPAR,ENORM C C FORTRAN-SUPPLIED ... AMAX1,SQRT,MIN0 C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE C C ********** INTEGER I,J,JP1,K,KMAX,MINMN REAL AJNORM,EPSMCH,ONE,P05,SUM,TEMP,ZERO REAL SPMPAR,ENORM DATA ONE,P05,ZERO /1.0E0,5.0E-2,0.0E0/ C C EPSMCH IS THE MACHINE PRECISION. C EPSMCH = SPMPAR(1) C C COMPUTE THE INITIAL COLUMN NORMS AND INITIALIZE SEVERAL ARRAYS. C DO 10 J = 1, N ACNORM(J) = ENORM(M,A(1,J)) RDIAG(J) = ACNORM(J) WA(J) = RDIAG(J) IF (PIVOT) IPVT(J) = J 10 CONTINUE C C REDUCE A TO R WITH HOUSEHOLDER TRANSFORMATIONS. C MINMN = MIN0(M,N) DO 110 J = 1, MINMN IF (.NOT.PIVOT) GO TO 40 C C BRING THE COLUMN OF LARGEST NORM INTO THE PIVOT POSITION. C KMAX = J DO 20 K = J, N IF (RDIAG(K) .GT. RDIAG(KMAX)) KMAX = K 20 CONTINUE IF (KMAX .EQ. J) GO TO 40 DO 30 I = 1, M TEMP = A(I,J) A(I,J) = A(I,KMAX) A(I,KMAX) = TEMP 30 CONTINUE RDIAG(KMAX) = RDIAG(J) WA(KMAX) = WA(J) K = IPVT(J) IPVT(J) = IPVT(KMAX) IPVT(KMAX) = K 40 CONTINUE C C COMPUTE THE HOUSEHOLDER TRANSFORMATION TO REDUCE THE C J-TH COLUMN OF A TO A MULTIPLE OF THE J-TH UNIT VECTOR. C AJNORM = ENORM(M-J+1,A(J,J)) IF (AJNORM .EQ. ZERO) GO TO 100 IF (A(J,J) .LT. ZERO) AJNORM = -AJNORM DO 50 I = J, M A(I,J) = A(I,J)/AJNORM 50 CONTINUE A(J,J) = A(J,J) + ONE C C APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS C AND UPDATE THE NORMS. C JP1 = J + 1 IF (N .LT. JP1) GO TO 100 DO 90 K = JP1, N SUM = ZERO DO 60 I = J, M SUM = SUM + A(I,J)*A(I,K) 60 CONTINUE TEMP = SUM/A(J,J) DO 70 I = J, M A(I,K) = A(I,K) - TEMP*A(I,J) 70 CONTINUE IF (.NOT.PIVOT .OR. RDIAG(K) .EQ. ZERO) GO TO 80 TEMP = A(J,K)/RDIAG(K) RDIAG(K) = RDIAG(K)*SQRT(AMAX1(ZERO,ONE-TEMP**2)) IF (P05*(RDIAG(K)/WA(K))**2 .GT. EPSMCH) GO TO 80 RDIAG(K) = ENORM(M-J,A(JP1,K)) WA(K) = RDIAG(K) 80 CONTINUE 90 CONTINUE 100 CONTINUE RDIAG(J) = -AJNORM 110 CONTINUE RETURN C C LAST CARD OF SUBROUTINE QRFAC. C END SUBROUTINE QRSOLV(N,R,LDR,IPVT,DIAG,QTB,X,SDIAG,WA) INTEGER N,LDR INTEGER IPVT(N) REAL R(LDR,N),DIAG(N),QTB(N),X(N),SDIAG(N),WA(N) C ********** C C SUBROUTINE QRSOLV C C GIVEN AN M BY N MATRIX A, AN N BY N DIAGONAL MATRIX D, C AND AN M-VECTOR B, THE PROBLEM IS TO DETERMINE AN X WHICH C SOLVES THE SYSTEM C C A*X = B , D*X = 0 , C C IN THE LEAST SQUARES SENSE. C C THIS SUBROUTINE COMPLETES THE SOLUTION OF THE PROBLEM C IF IT IS PROVIDED WITH THE NECESSARY INFORMATION FROM THE C QR FACTORIZATION, WITH COLUMN PIVOTING, OF A. THAT IS, IF C A*P = Q*R, WHERE P IS A PERMUTATION MATRIX, Q HAS ORTHOGONAL C COLUMNS, AND R IS AN UPPER TRIANGULAR MATRIX WITH DIAGONAL C ELEMENTS OF NONINCREASING MAGNITUDE, THEN QRSOLV EXPECTS C THE FULL UPPER TRIANGLE OF R, THE PERMUTATION MATRIX P, C AND THE FIRST N COMPONENTS OF (Q TRANSPOSE)*B. THE SYSTEM C A*X = B, D*X = 0, IS THEN EQUIVALENT TO C C T T C R*Z = Q *B , P *D*P*Z = 0 , C C WHERE X = P*Z. IF THIS SYSTEM DOES NOT HAVE FULL RANK, C THEN A LEAST SQUARES SOLUTION IS OBTAINED. ON OUTPUT QRSOLV C ALSO PROVIDES AN UPPER TRIANGULAR MATRIX S SUCH THAT C C T T T C P *(A *A + D*D)*P = S *S . C C S IS COMPUTED WITHIN QRSOLV AND MAY BE OF SEPARATE INTEREST. C C THE SUBROUTINE STATEMENT IS C C SUBROUTINE QRSOLV(N,R,LDR,IPVT,DIAG,QTB,X,SDIAG,WA) C C WHERE C C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE ORDER OF R. C C R IS AN N BY N ARRAY. ON INPUT THE FULL UPPER TRIANGLE C MUST CONTAIN THE FULL UPPER TRIANGLE OF THE MATRIX R. C ON OUTPUT THE FULL UPPER TRIANGLE IS UNALTERED, AND THE C STRICT LOWER TRIANGLE CONTAINS THE STRICT UPPER TRIANGLE C (TRANSPOSED) OF THE UPPER TRIANGULAR MATRIX S. C C LDR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY R. C C IPVT IS AN INTEGER INPUT ARRAY OF LENGTH N WHICH DEFINES THE C PERMUTATION MATRIX P SUCH THAT A*P = Q*R. COLUMN J OF P C IS COLUMN IPVT(J) OF THE IDENTITY MATRIX. C C DIAG IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE C DIAGONAL ELEMENTS OF THE MATRIX D. C C QTB IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE FIRST C N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*B. C C X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE LEAST C SQUARES SOLUTION OF THE SYSTEM A*X = B, D*X = 0. C C SDIAG IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE C DIAGONAL ELEMENTS OF THE UPPER TRIANGULAR MATRIX S. C C WA IS A WORK ARRAY OF LENGTH N. C C SUBPROGRAMS CALLED C C FORTRAN-SUPPLIED ... ABS,SQRT C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE C C ********** INTEGER I,J,JP1,K,KP1,L,NSING REAL COS,COTAN,P5,P25,QTBPJ,SIN,SUM,TAN,TEMP,ZERO DATA P5,P25,ZERO /5.0E-1,2.5E-1,0.0E0/ C C COPY R AND (Q TRANSPOSE)*B TO PRESERVE INPUT AND INITIALIZE S. C IN PARTICULAR, SAVE THE DIAGONAL ELEMENTS OF R IN X. C DO 20 J = 1, N DO 10 I = J, N R(I,J) = R(J,I) 10 CONTINUE X(J) = R(J,J) WA(J) = QTB(J) 20 CONTINUE C C ELIMINATE THE DIAGONAL MATRIX D USING A GIVENS ROTATION. C DO 100 J = 1, N C C PREPARE THE ROW OF D TO BE ELIMINATED, LOCATING THE C DIAGONAL ELEMENT USING P FROM THE QR FACTORIZATION. C L = IPVT(J) IF (DIAG(L) .EQ. ZERO) GO TO 90 DO 30 K = J, N SDIAG(K) = ZERO 30 CONTINUE SDIAG(J) = DIAG(L) C C THE TRANSFORMATIONS TO ELIMINATE THE ROW OF D C MODIFY ONLY A SINGLE ELEMENT OF (Q TRANSPOSE)*B C BEYOND THE FIRST N, WHICH IS INITIALLY ZERO. C QTBPJ = ZERO DO 80 K = J, N C C DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE C APPROPRIATE ELEMENT IN THE CURRENT ROW OF D. C IF (SDIAG(K) .EQ. ZERO) GO TO 70 IF (ABS(R(K,K)) .GE. ABS(SDIAG(K))) GO TO 40 COTAN = R(K,K)/SDIAG(K) SIN = P5/SQRT(P25+P25*COTAN**2) COS = SIN*COTAN GO TO 50 40 CONTINUE TAN = SDIAG(K)/R(K,K) COS = P5/SQRT(P25+P25*TAN**2) SIN = COS*TAN 50 CONTINUE C C COMPUTE THE MODIFIED DIAGONAL ELEMENT OF R AND C THE MODIFIED ELEMENT OF ((Q TRANSPOSE)*B,0). C R(K,K) = COS*R(K,K) + SIN*SDIAG(K) TEMP = COS*WA(K) + SIN*QTBPJ QTBPJ = -SIN*WA(K) + COS*QTBPJ WA(K) = TEMP C C ACCUMULATE THE TRANFORMATION IN THE ROW OF S. C KP1 = K + 1 IF (N .LT. KP1) GO TO 70 DO 60 I = KP1, N TEMP = COS*R(I,K) + SIN*SDIAG(I) SDIAG(I) = -SIN*R(I,K) + COS*SDIAG(I) R(I,K) = TEMP 60 CONTINUE 70 CONTINUE 80 CONTINUE 90 CONTINUE C C STORE THE DIAGONAL ELEMENT OF S AND RESTORE C THE CORRESPONDING DIAGONAL ELEMENT OF R. C SDIAG(J) = R(J,J) R(J,J) = X(J) 100 CONTINUE C C SOLVE THE TRIANGULAR SYSTEM FOR Z. IF THE SYSTEM IS C SINGULAR, THEN OBTAIN A LEAST SQUARES SOLUTION. C NSING = N DO 110 J = 1, N IF (SDIAG(J) .EQ. ZERO .AND. NSING .EQ. N) NSING = J - 1 IF (NSING .LT. N) WA(J) = ZERO 110 CONTINUE IF (NSING .LT. 1) GO TO 150 DO 140 K = 1, NSING J = NSING - K + 1 SUM = ZERO JP1 = J + 1 IF (NSING .LT. JP1) GO TO 130 DO 120 I = JP1, NSING SUM = SUM + R(I,J)*WA(I) 120 CONTINUE 130 CONTINUE WA(J) = (WA(J) - SUM)/SDIAG(J) 140 CONTINUE 150 CONTINUE C C PERMUTE THE COMPONENTS OF Z BACK TO COMPONENTS OF X. C DO 160 J = 1, N L = IPVT(J) X(L) = WA(J) 160 CONTINUE RETURN C C LAST CARD OF SUBROUTINE QRSOLV. C END SUBROUTINE R1MPYQ(M,N,A,LDA,V,W) INTEGER M,N,LDA REAL A(LDA,N),V(N),W(N) C ********** C C SUBROUTINE R1MPYQ C C GIVEN AN M BY N MATRIX A, THIS SUBROUTINE COMPUTES A*Q WHERE C Q IS THE PRODUCT OF 2*(N - 1) TRANSFORMATIONS C C GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1) C C AND GV(I), GW(I) ARE GIVENS ROTATIONS IN THE (I,N) PLANE WHICH C ELIMINATE ELEMENTS IN THE I-TH AND N-TH PLANES, RESPECTIVELY. C Q ITSELF IS NOT GIVEN, RATHER THE INFORMATION TO RECOVER THE C GV, GW ROTATIONS IS SUPPLIED. C C THE SUBROUTINE STATEMENT IS C C SUBROUTINE R1MPYQ(M,N,A,LDA,V,W) C C WHERE C C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER C OF ROWS OF A. C C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER C OF COLUMNS OF A. C C A IS AN M BY N ARRAY. ON INPUT A MUST CONTAIN THE MATRIX C TO BE POSTMULTIPLIED BY THE ORTHOGONAL MATRIX Q C DESCRIBED ABOVE. ON OUTPUT A*Q HAS REPLACED A. C C LDA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M C WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY A. C C V IS AN INPUT ARRAY OF LENGTH N. V(I) MUST CONTAIN THE C INFORMATION NECESSARY TO RECOVER THE GIVENS ROTATION GV(I) C DESCRIBED ABOVE. C C W IS AN INPUT ARRAY OF LENGTH N. W(I) MUST CONTAIN THE C INFORMATION NECESSARY TO RECOVER THE GIVENS ROTATION GW(I) C DESCRIBED ABOVE. C C SUBROUTINES CALLED C C FORTRAN-SUPPLIED ... ABS,SQRT C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE C C ********** INTEGER I,J,NMJ,NM1 REAL COS,ONE,SIN,TEMP DATA ONE /1.0E0/ C C APPLY THE FIRST SET OF GIVENS ROTATIONS TO A. C NM1 = N - 1 IF (NM1 .LT. 1) GO TO 50 DO 20 NMJ = 1, NM1 J = N - NMJ IF (ABS(V(J)) .GT. ONE) COS = ONE/V(J) IF (ABS(V(J)) .GT. ONE) SIN = SQRT(ONE-COS**2) IF (ABS(V(J)) .LE. ONE) SIN = V(J) IF (ABS(V(J)) .LE. ONE) COS = SQRT(ONE-SIN**2) DO 10 I = 1, M TEMP = COS*A(I,J) - SIN*A(I,N) A(I,N) = SIN*A(I,J) + COS*A(I,N) A(I,J) = TEMP 10 CONTINUE 20 CONTINUE C C APPLY THE SECOND SET OF GIVENS ROTATIONS TO A. C DO 40 J = 1, NM1 IF (ABS(W(J)) .GT. ONE) COS = ONE/W(J) IF (ABS(W(J)) .GT. ONE) SIN = SQRT(ONE-COS**2) IF (ABS(W(J)) .LE. ONE) SIN = W(J) IF (ABS(W(J)) .LE. ONE) COS = SQRT(ONE-SIN**2) DO 30 I = 1, M TEMP = COS*A(I,J) + SIN*A(I,N) A(I,N) = -SIN*A(I,J) + COS*A(I,N) A(I,J) = TEMP 30 CONTINUE 40 CONTINUE 50 CONTINUE RETURN C C LAST CARD OF SUBROUTINE R1MPYQ. C END SUBROUTINE R1UPDT(M,N,S,LS,U,V,W,SING) INTEGER M,N,LS LOGICAL SING REAL S(LS),U(M),V(N),W(M) C ********** C C SUBROUTINE R1UPDT C C GIVEN AN M BY N LOWER TRAPEZOIDAL MATRIX S, AN M-VECTOR U, C AND AN N-VECTOR V, THE PROBLEM IS TO DETERMINE AN C ORTHOGONAL MATRIX Q SUCH THAT C C T C (S + U*V )*Q C C IS AGAIN LOWER TRAPEZOIDAL. C C THIS SUBROUTINE DETERMINES Q AS THE PRODUCT OF 2*(N - 1) C TRANSFORMATIONS C C GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1) C C WHERE GV(I), GW(I) ARE GIVENS ROTATIONS IN THE (I,N) PLANE C WHICH ELIMINATE ELEMENTS IN THE I-TH AND N-TH PLANES, C RESPECTIVELY. Q ITSELF IS NOT ACCUMULATED, RATHER THE C INFORMATION TO RECOVER THE GV, GW ROTATIONS IS RETURNED. C C THE SUBROUTINE STATEMENT IS C C SUBROUTINE R1UPDT(M,N,S,LS,U,V,W,SING) C C WHERE C C M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER C OF ROWS OF S. C C N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER C OF COLUMNS OF S. N MUST NOT EXCEED M. C C S IS AN ARRAY OF LENGTH LS. ON INPUT S MUST CONTAIN THE LOWER C TRAPEZOIDAL MATRIX S STORED BY COLUMNS. ON OUTPUT S CONTAINS C THE LOWER TRAPEZOIDAL MATRIX PRODUCED AS DESCRIBED ABOVE. C C LS IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN C (N*(2*M-N+1))/2. C C U IS AN INPUT ARRAY OF LENGTH M WHICH MUST CONTAIN THE C VECTOR U. C C V IS AN ARRAY OF LENGTH N. ON INPUT V MUST CONTAIN THE VECTOR C V. ON OUTPUT V(I) CONTAINS THE INFORMATION NECESSARY TO C RECOVER THE GIVENS ROTATION GV(I) DESCRIBED ABOVE. C C W IS AN OUTPUT ARRAY OF LENGTH M. W(I) CONTAINS INFORMATION C NECESSARY TO RECOVER THE GIVENS ROTATION GW(I) DESCRIBED C ABOVE. C C SING IS A LOGICAL OUTPUT VARIABLE. SING IS SET TRUE IF ANY C OF THE DIAGONAL ELEMENTS OF THE OUTPUT S ARE ZERO. OTHERWISE C SING IS SET FALSE. C C SUBPROGRAMS CALLED C C MINPACK-SUPPLIED ... SPMPAR C C FORTRAN-SUPPLIED ... ABS,SQRT C C ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980. C BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE, C JOHN L. NAZARETH C C ********** INTEGER I,J,JJ,L,NMJ,NM1 REAL COS,COTAN,GIANT,ONE,P5,P25,SIN,TAN,TAU,TEMP,ZERO REAL SPMPAR DATA ONE,P5,P25,ZERO /1.0E0,5.0E-1,2.5E-1,0.0E0/ C C GIANT IS THE LARGEST MAGNITUDE. C GIANT = SPMPAR(3) C C INITIALIZE THE DIAGONAL ELEMENT POINTER. C JJ = (N*(2*M - N + 1))/2 - (M - N) C C MOVE THE NONTRIVIAL PART OF THE LAST COLUMN OF S INTO W. C L = JJ DO 10 I = N, M W(I) = S(L) L = L + 1 10 CONTINUE C C ROTATE THE VECTOR V INTO A MULTIPLE OF THE N-TH UNIT VECTOR C IN SUCH A WAY THAT A SPIKE IS INTRODUCED INTO W. C NM1 = N - 1 IF (NM1 .LT. 1) GO TO 70 DO 60 NMJ = 1, NM1 J = N - NMJ JJ = JJ - (M - J + 1) W(J) = ZERO IF (V(J) .EQ. ZERO) GO TO 50 C C DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE C J-TH ELEMENT OF V. C IF (ABS(V(N)) .GE. ABS(V(J))) GO TO 20 COTAN = V(N)/V(J) SIN = P5/SQRT(P25+P25*COTAN**2) COS = SIN*COTAN TAU = ONE IF (ABS(COS)*GIANT .GT. ONE) TAU = ONE/COS GO TO 30 20 CONTINUE TAN = V(J)/V(N) COS = P5/SQRT(P25+P25*TAN**2) SIN = COS*TAN TAU = SIN 30 CONTINUE C C APPLY THE TRANSFORMATION TO V AND STORE THE INFORMATION C NECESSARY TO RECOVER THE GIVENS ROTATION. C V(N) = SIN*V(J) + COS*V(N) V(J) = TAU C C APPLY THE TRANSFORMATION TO S AND EXTEND THE SPIKE IN W. C L = JJ DO 40 I = J, M TEMP = COS*S(L) - SIN*W(I) W(I) = SIN*S(L) + COS*W(I) S(L) = TEMP L = L + 1 40 CONTINUE 50 CONTINUE 60 CONTINUE 70 CONTINUE C C ADD THE SPIKE FROM THE RANK 1 UPDATE TO W. C DO 80 I = 1, M W(I) = W(I) + V(N)*U(I) 80 CONTINUE C C ELIMINATE THE SPIKE. C SING = .FALSE. IF (NM1 .LT. 1) GO TO 140 DO 130 J = 1, NM1 IF (W(J) .EQ. ZERO) GO TO 120 C C DETERMINE A GIVENS ROTATION WHICH ELIMINATES THE C J-TH ELEMENT OF THE SPIKE. C IF (ABS(S(JJ)) .GE. ABS(W(J))) GO TO 90 COTAN = S(JJ)/W(J) SIN = P5/SQRT(P25+P25*COTAN**2) COS = SIN*COTAN TAU = ONE IF (ABS(COS)*GIANT .GT. ONE) TAU = ONE/COS GO TO 100 90 CONTINUE TAN = W(J)/S(JJ) COS = P5/SQRT(P25+P25*TAN**2) SIN = COS*TAN TAU = SIN 100 CONTINUE C C APPLY THE TRANSFORMATION TO S AND REDUCE THE SPIKE IN W. C L = JJ DO 110 I = J, M TEMP = COS*S(L) + SIN*W(I) W(I) = -SIN*S(L) + COS*W(I) S(L) = TEMP L = L + 1 110 CONTINUE C C STORE THE INFORMATION NECESSARY TO RECOVER THE C GIVENS ROTATION. C W(J) = TAU 120 CONTINUE C C TEST FOR ZERO DIAGONAL ELEMENTS IN THE OUTPUT S. C IF (S(JJ) .EQ. ZERO) SING = .TRUE. JJ = JJ + (M - J + 1) 130 CONTINUE 140 CONTINUE C C MOVE W BACK INTO THE LAST COLUMN OF THE OUTPUT S. C L = JJ DO 150 I = N, M S(L) = W(I) L = L + 1 150 CONTINUE IF (S(JJ) .EQ. ZERO) SING = .TRUE. RETURN C C LAST CARD OF SUBROUTINE R1UPDT. C END SUBROUTINE SMPLX (A,B0,C,KA,M,N0,IND,IBASIS,X,Z,ITER,MXITER, * NUMLE,NUMGE,BI,WK,IWK) C----------------------------------------------------------------------- C SIMPLEX PROCEDURE FOR SOLVING LINEAR PROGRAMMING PROBLEMS C----------------------------------------------------------------------- C WRITTEN BY ALFRED H. MORRIS JR. C NAVAL SURFACE WEAPONS CENTER C DAHLGREN, VIRGINIA C------------------------ C INITIAL VERSION DEC 1977 C LAST UPDATE OCT 1990 C------------------------ DIMENSION A(KA,N0),B0(M),C(N0) DIMENSION IBASIS(M),BI(M,M) DIMENSION X(*),WK(*),IWK(*) C------------------------ C DIMENSION X(N0+NUMLE+NUMGE) C DIMENSION WK(2*M),IWK(2*M+N0) C------------------------ C C ********** EPS0 IS A MACHINE DEPENDENT PARAMETER. ASSIGN EPS0 C THE VALUE U WHERE U IS THE SMALLEST POSITIVE FLOATING C POINT NUMBER SUCH THAT 1.0 + U .GT. 1.0. C EPS0 = SPMPAR(1) C C------------------------ RERRMN = 10.0*EPS0 RERRMX = 1.E-4 IF (EPS0 .LT. 1.E-13) RERRMX = 1.E-5 C IP = M + N0 + 1 CALL SMPLX1(A,B0,C,KA,M,N0,IND,IBASIS,X,Z,ITER,MXITER, 1 EPS0,RERRMN,RERRMX,RERR,NUMLE,NUMGE,BI, 2 WK(1),WK(M+1),IWK(1),IWK(IP)) RETURN END SUBROUTINE SMPLX1 (A,B0,C,KA,M,N0,IND,IBASIS,R,Z,ITER,MXITER, * EPS0,RERRMN,RERRMX,RERR,NUMLE,NUMGE,BI,XB,Y,BASIS,INDEX) C---------------------- C NSTEP = 1 ELIMINATE THE NEGATIVE VARIABLES C NSTEP = 2 PHASE 1 OF THE SIMPLEX ALGORITHM C NSTEP = 3 PHASE 2 OF THE SIMPLEX ALGORITHM C---------------------- C MXITER = THE MAXIMUM NUMBER OF ITERATIONS PERMITTED C ITER = THE NUMBER OF THE CURRENT ITERATION C ICOUNT = THE NUMBER OF ITERATIONS SINCE THE LAST INVERSION C---------------------- C NUMLE = THE NUMBER OF .LE. CONSTRAINTS C NUMGE = THE NUMBER OF .GE. CONSTRAINTS C---------------------- C THE ROUTINE ASSUMES THAT THE .LE. CONSTRAINTS PRECEDE THE .GE. C CONSTRAINTS AND THAT THE .EQ. CONSTRAINTS COME LAST. THERE ARE C M CONSTRAINTS. X(N0+I) IS THE SLACK, SURPLUS, OR ARTIFICIAL C VARIABLE FOR THE I-TH CONSTRAINT (I=1,...,M). C---------------------- C N0 = THE NUMBER OF ORGINAL VARIABLES C NS = THE NUMBER OF ORGINAL AND SLACK VARIABLES C N = THE NUMBER OF ORGINAL, SLACK, AND SURPLUS VARIABLES C NUM = THE TOTAL NUMBER OF VARIABLES C---------------------- C RERRMN = THE SMALLEST RELATIVE ERROR TOLERANCE USED C RERRMX = THE LARGEST RELATIVE ERROR TOLERACE USED C RERR = THE ESTIMATED CURRENT RELATIVE ERROR C---------------------- C ASSUME THAT C B0 = (B0(1),...,B0(M)) C C = (C(1),...,C(N0)) C Z = C(1)*X(1)+...+C(N0)*X(N0) C THE PROBLEM IS TO MAXIMIZE Z SUBJECT TO C AX(LE,EQ,GE)B0 C X.GE.0 C---------------------- C ON INPUT IND CAN HAVE THE VALUES C IND = 0 NO BEGINNING BASIS IS PROVIDED BY THE USER C IND = 1 THE ARRAY IBASIS HAS BEEN SET BY THE USER C ON OUTPUT IND IS ASSIGNED ONE OF THE VALUES C IND = 0 Z WAS SUCCESSFULLY MAXIMIZED C IND = 1 THE PROBLEM HAS NO FEASIBLE SOLUTION C IND = 2 MXITER ITERATIONS WERE PERFORMED C IND = 3 SUFFICIENT ACCURACY CANNOT BE MAINTAINED C IND = 4 THE PROBLEM HAS AN UNBOUNDED SOLUTION C IND = 5 THERE IS AN INPUT ERROR C IND = 6 Z WAS POSSIBLY MAXIMIZED C---------------------- C BASIS IS AN INTEGER ARRAY OF DIMENSION N0+M. FOR J.LE.N C BASIS(J) = 1 IF X(J) IS A BASIC VARIABLE C BASIS(J) = 0 IF X(J) IS NOT A BASIC VARIABLE C IF THE BASIC VARIABLES ARE X(I1),...,X(IM) THEN C IBASIS = (I1,...,IM) C ALSO XB(1),...,XB(M) ARE THE CORRESPONDING VALUES OF THE C BASIC VARIABLES. C---------------------- C BI IS AN MXM ARRAY CONTAINING THE INVERSE OF THE BASIS MATRIX. C---------------------- C R IS AN ARRAY OF DIMENSION N. ON OUTPUT R CONTAINS THE CURRENT C VALUE OF X. DURING COMPUTATION R NORMALLY CONTAINS THE REDUCED C COSTS USED FOR THE SELECTION OF THE VARIABLE TO BE MADE BASIC. C---------------------- REAL A(KA,N0), B0(M), C(N0) REAL BI(M,M), XB(M), Y(M), R(*) INTEGER IBASIS(M), BASIS(*) INTEGER BFLAG, INDEX(M) DOUBLE PRECISION DSUM, DSUMP, DSUMN, DT C---------------------- C C ****** XMAX IS A MACHINE DEPENDENT CONSTANT. XMAX IS THE C LARGEST POSITIVE FLOATING POINT NUMBER. C XMAX = SPMPAR(3) C C---------------------- ITER = 0 ICOUNT = 0 MCHECK = MIN0(5,1 + M/15) Z = 0.0 C C CHECK FOR INPUT ERRORS C MS = NUMLE + NUMGE IF (M .LT. 2 .OR. N0 .LT. 2 .OR. MS .GT. M .OR. KA .LT. M) * GO TO 12 DO 10 I = 1,M IF (B0(I) .LT. 0.0) GO TO 12 10 XB(I) = 0.0 RTOL = XMAX DO 11 I = 1,N0 IF (C(I) .NE. 0.0) RTOL = AMIN1(ABS(C(I)),RTOL) 11 CONTINUE RTOL = RERRMX*RTOL GO TO 20 C 12 IND = 5 RETURN C C FORMATION OF THE IBASIS AND BASIS ARRAYS. (IF IND = 1 C THEN THE IBASIS ARRAY IS DEFINED BY THE USER.) C 20 NS = N0 + NUMLE N = NS + NUMGE IF (IND .EQ. 0) GO TO 30 NUM = N DO 21 I = 1,M IF (IBASIS(I) .GT. N) NUM = NUM + 1 21 CONTINUE GO TO 32 22 IF (IND .EQ. 0) GO TO 590 IND = 0 C 30 NUM = N0 + M DO 31 I = 1,M 31 IBASIS(I) = N0 + I 32 BFLAG = 0 DO 33 I = 1,N 33 BASIS(I) = 0 DO 34 I = 1,M KI = IBASIS(I) 34 BASIS(KI) = 1 IF (IND .EQ. 1) GO TO 100 C C CALCULATION OF XB AND BI WHEN IND = 0 C RERR = RERRMN DO 41 J = 1,M XB(J) = B0(J) DO 40 I = 1,M 40 BI(I,J) = 0.0 BI(J,J) = 1.0 41 CONTINUE IF (NUMGE .EQ. 0) GO TO 630 JMIN = NUMLE + 1 DO 42 J = JMIN,MS XB(J) = -XB(J) BI(J,J) = -1.0 42 CONTINUE GO TO 601 C C REORDER THE BASIS C 100 IBEG = 1 IEND = M DO 102 I = 1,M IF (IBASIS(I) .LE. N0) GO TO 101 INDEX(IBEG) = IBASIS(I) IBEG = IBEG + 1 GO TO 102 101 INDEX(IEND) = IBASIS(I) IEND = IEND - 1 102 CONTINUE IF (IEND .EQ. M) GO TO 22 DO 103 I = 1,M 103 IBASIS(I) = INDEX(I) C C REINVERSION OF THE BASIS MATRIX C DO 132 J = 1,M KJ = IBASIS(J) IF (KJ .LE. N0) GO TO 110 IF (KJ .LE. NS) GO TO 120 IF (KJ .LE. N) GO TO 130 GO TO 120 C 110 DO 111 I = 1,M 111 BI(I,J) = A(I,KJ) GO TO 132 C 120 L = KJ - N0 DO 121 I = 1,M 121 BI(I,J) = 0.0 BI(L,J) = 1.0 GO TO 132 C 130 L = KJ - N0 DO 131 I = 1,M 131 BI(I,J) = 0.0 BI(L,J) = -1.0 132 CONTINUE C ICOUNT = 0 CALL CROUT1 (BI, M, M, IEND, INDEX, Y, JCOL, IERR) IF (IERR .NE. 0) GO TO 580 C C CHECK THE ACCURACY OF BI AND RESET RERR C BNORM = 0.0 DO 142 J = 1,M KJ = IBASIS(J) IF (KJ .LE. N0) GO TO 140 SUM = 1.0 GO TO 142 140 SUM = 0.0 DO 141 I = 1,M 141 SUM = SUM + ABS(A(I,KJ)) 142 BNORM = AMAX1(BNORM,SUM) C BINORM = 0.0 DO 151 J = 1,M SUM = 0.0 DO 150 I = 1,M 150 SUM = SUM + ABS(BI(I,J)) BINORM = AMAX1(BINORM,SUM) 151 CONTINUE RERR = AMAX1(RERRMN,EPS0*BNORM*BINORM) IF (RERR .GT. 1.E-2) GO TO 580 BFLAG = 0 C C RECALCULATION OF XB C 180 DO 183 I = 1,M DSUMP = 0.D0 DSUMN = 0.D0 DO 182 L = 1,M DT = BI(I,L)*B0(L) IF (DT .GT. 0.D0) GO TO 181 DSUMN = DSUMN + DT GO TO 182 181 DSUMP = DSUMP + DT 182 CONTINUE XB(I) = DSUMP + DSUMN S = DSUMP T = DSUMN TOL = RERRMX*AMAX1(S,-T) IF (ABS(XB(I)) .LT. TOL) XB(I) = 0.0 183 CONTINUE GO TO 601 C C FIND THE NEXT VECTOR A(--,JP) TO BE INSERTED INTO C THE BASIS C 200 JP = 0 RMIN = 0.0 IF (NSTEP .EQ. 3) RMIN = -RTOL DO 201 J = 1,N0 IF (BASIS(J) .NE. 0) GO TO 201 IF (R(J) .GE. RMIN) GO TO 201 JP = J RMIN = R(J) 201 CONTINUE IF (N0 .EQ. N) GO TO 203 JMIN = N0 + 1 RMIN = RMIN*1.1 DO 202 J = JMIN,N IF (BASIS(J) .NE. 0) GO TO 202 IF (R(J) .GE. RMIN) GO TO 202 JP = J RMIN = R(J) 202 CONTINUE 203 IF (JP .NE. 0) GO TO 300 IF (NSTEP - 2) 800,230,250 C C INSERT THE VALUES OF THE ORGINAL, SLACK, AND SURPLUS C VARIABLES INTO R. THEN TERMINATE. C 220 DO 221 J = 1,N 221 R(J) = 0.0 DO 222 I = 1,M KI = IBASIS(I) IF (KI .LE. N) R(KI) = XB(I) 222 CONTINUE RETURN C C COMPLETION OF THE NSTEP = 2 CASE C 230 DO 231 I = 1,M IF (IBASIS(I) .LE. N) GO TO 231 IF (XB(I) .GT. 0.0) GO TO 800 231 CONTINUE GO TO 680 C 240 IF (ICOUNT .GE. 5) GO TO 100 IND = 1 GO TO 220 C C COMPLETION OF THE NSTEP = 3 CASE C 250 IF (RERR .GT. 1.E-2) GO TO 251 IND = 0 GO TO 800 251 IF (ICOUNT .GE. 5) GO TO 100 IND = 6 GO TO 800 C C IF MXITER ITERATIONS HAVE NOT BEEN PERFORMED THEN C BEGIN THE NEXT ITERATION. COMPUTE THE JP-TH COLUMN C OF BI*A AND STORE IT IN Y. C 300 IF (ITER .LT. MXITER) GO TO 301 IND = 2 GO TO 220 301 ITER = ITER + 1 ICOUNT = ICOUNT + 1 IF (JP .GT. NS) GO TO 330 IF (JP .GT. N0) GO TO 320 C NROW = 0 AMAX = 0.0 DO 305 I = 1,M IF (A(I,JP) .EQ. 0.0) GO TO 305 NROW = NROW + 1 INDEX(NROW) = I AMAX = AMAX1(ABS(A(I,JP)),AMAX) 305 CONTINUE IF (NROW .NE. 0) GO TO 310 IND = 4 GO TO 220 C 310 RERR1 = RERRMX*AMAX DO 313 I = 1,M DSUM = 0.D0 DO 311 LL = 1,NROW L = INDEX(LL) DSUM = DSUM + DBLE(BI(I,L)*A(L,JP)) 311 CONTINUE Y(I) = DSUM IF (ABS(Y(I)) .GE. 5.E-3) GO TO 313 BMAX = 0.0 DO 312 L = 1,M BMAX = AMAX1(ABS(BI(I,L)),BMAX) 312 CONTINUE TOL = RERR1*BMAX IF (ABS(Y(I)) .LT. TOL) Y(I) = 0.0 313 CONTINUE GO TO 350 C 320 L = JP - N0 DO 321 I = 1,M Y(I) = BI(I,L) 321 CONTINUE GO TO 350 C 330 L = JP - N0 DO 331 I = 1,M Y(I) = -BI(I,L) 331 CONTINUE C 350 DO 351 I = 1,M IF (Y(I) .NE. 0.0) GO TO 360 351 CONTINUE R(JP) = 0.0 ITER = ITER - 1 ICOUNT = ICOUNT - 1 GO TO 200 C 360 IF (NSTEP - 2) 400,430,440 C C FINDING THE VARIABLE XB(IP) TO BE MADE NONBASIC C FOR THE NSTEP = 1 CASE C 400 NPOS = 0 IP = 0 EPS = 0.0 EPSI = XMAX DO 403 I = 1,M IF (XB(I) .LT. 0.0 .OR. Y(I) .LE. 0.0) GO TO 403 RATIO = XB(I)/Y(I) IF (RATIO - EPSI) 401,402,403 401 EPSI = RATIO NPOS = 1 INDEX(1) = I GO TO 403 402 NPOS = NPOS + 1 INDEX(NPOS) = I 403 CONTINUE IF (NPOS .EQ. 0) GO TO 420 IF (EPSI .EQ. 0.0) GO TO 460 C DO 410 I = 1,M IF (XB(I) .GE. 0.0 .OR. Y(I) .GE. 0.0) GO TO 410 RATIO = XB(I)/Y(I) IF (RATIO .GT. EPSI) GO TO 410 IF (RATIO .LT. EPS) GO TO 410 EPS = RATIO IP = I 410 CONTINUE IF (IP .NE. 0) GO TO 500 GO TO 460 C 420 DO 421 I = 1,M IF (XB(I) .GE. 0.0 .OR. Y(I) .GE. 0.0) GO TO 421 RATIO = XB(I)/Y(I) IF (RATIO .LT. EPS) GO TO 421 EPS = RATIO IP = I 421 CONTINUE GO TO 500 C C FINDING THE VARIABLE XB(IP) TO BE MADE NONBASIC C FOR THE NSTEP = 2 CASE C 430 NPOS = 0 EPSI = XMAX DO 433 I = 1,M IF (Y(I) .LE. 0.0) GO TO 433 RATIO = XB(I)/Y(I) IF (RATIO - EPSI) 431,432,433 431 EPSI = RATIO NPOS = 1 INDEX(1) = I GO TO 433 432 NPOS = NPOS + 1 INDEX(NPOS) = I 433 CONTINUE GO TO 450 C C FINDING THE VARIABLE XB(IP) TO BE MADE NONBASIC C FOR THE NSTEP = 3 CASE C 440 NPOS = 0 EPSI = XMAX DO 445 I = 1,M IF (Y(I)) 441,445,442 441 IF (IBASIS(I) .LE. N) GO TO 445 IP = I GO TO 500 442 RATIO = XB(I)/Y(I) IF (RATIO - EPSI) 443,444,445 443 EPSI = RATIO NPOS = 1 INDEX(1) = I GO TO 445 444 NPOS = NPOS + 1 INDEX(NPOS) = I 445 CONTINUE C 450 IF (NPOS .NE. 0) GO TO 460 IF (ICOUNT .GE. 5) GO TO 100 IND = 4 GO TO 220 C C TIE BREAKING PROCEDURE C 460 IP = INDEX(1) IF (NPOS .EQ. 1) GO TO 500 IP = 0 BMIN = XMAX CMIN = XMAX DO 464 II = 1,NPOS I = INDEX(II) L = IBASIS(I) IF (L .GT. N0) GO TO 461 IF (C(L) .LE. 0.0) CMIN = AMIN1(0.0,CMIN) IF (C(L) .GT. CMIN) GO TO 464 IMIN = I CMIN = C(L) GO TO 464 461 IF (L .LE. N) GO TO 462 IP = I GO TO 500 462 LROW = L - N0 S = B0(LROW) IF (LROW .GT. NUMLE) GO TO 463 IF (S .GT. BMIN) GO TO 464 IP = I BMIN = S GO TO 464 463 S = -S BMIN = AMIN1(0.0,BMIN) IF (S .GT. BMIN) GO TO 464 IP = I BMIN = S 464 CONTINUE IF (CMIN .LE. 0.0 .OR. IP .EQ. 0) IP = IMIN C C TRANSFORMATION OF XB C 500 IF (XB(IP) .EQ. 0.0) GO TO 510 CONST = XB(IP)/Y(IP) DO 501 I = 1,M S = XB(I) XB(I) = XB(I) - CONST*Y(I) IF (XB(I) .GE. 0.0) GO TO 501 IF (S .GE. 0.0 .OR. XB(I) .GE. RERRMX*S) XB(I) = 0.0 501 CONTINUE XB(IP) = CONST C C TRANSFORMATION OF BI C 510 DO 512 J = 1,M IF (BI(IP,J) .EQ. 0.0) GO TO 512 CONST = BI(IP,J)/Y(IP) DO 511 I = 1,M 511 BI(I,J) = BI(I,J) - CONST*Y(I) BI(IP,J) = CONST 512 CONTINUE C C UPDATING IBASIS AND BASIS C IOUT = IBASIS(IP) IBASIS(IP) = JP BASIS(IOUT) = 0 BASIS(JP) = 1 IF (IOUT .GT. N) NUM = NUM - 1 C C CHECK THE ACCURACY OF BI AND RESET RERR C IF (RERR .GT. 1.E-2) GO TO 530 K = 0 DO 521 J = 1,M KJ = IBASIS(J) IF (KJ .GT. N0) GO TO 521 SUM = 0.0 DO 520 L = 1,M IF (A(L,KJ) .NE. 0.0) SUM = SUM + BI(J,L)*A(L,KJ) 520 CONTINUE RERR = AMAX1(RERR,ABS(1.0 - SUM)) K = K + 1 IF (K .GE. MCHECK) GO TO 522 521 CONTINUE 522 IF (RERR .LE. 1.E-2) GO TO 600 C C THE ACCURACY CRITERIA ARE NOT SATISFIED C 530 IF (ICOUNT .LT. 5) GO TO 600 BFLAG = 1 GO TO 100 C 580 IF (ITER .EQ. 0) GO TO 12 IF (BFLAG .EQ. 0) GO TO 590 BFLAG = 0 DO 581 IP = 1,M IF (JP .EQ. IBASIS(IP)) GO TO 582 581 CONTINUE 582 IBASIS(IP) = IOUT BASIS(JP) = 0 BASIS(IOUT) = 1 IF (IOUT .GT. N) NUM = NUM + 1 GO TO 100 C 590 IND = 3 GO TO 220 C C SET UP THE R ARRAY FOR THE NSTEP = 1 CASE C 600 IF (NSTEP - 2) 601,630,700 601 DO 602 J = 1,M IF (XB(J) .LT. 0.0) GO TO 610 602 CONTINUE GO TO 630 C 610 NSTEP = 1 M0 = 0 DO 611 L = 1,M IF (XB(L) .GE. 0.0) GO TO 611 M0 = M0 + 1 INDEX(M0) = L 611 CONTINUE C DO 623 J = 1,M DSUMP = 0.D0 DSUMN = 0.D0 DO 622 LL = 1,M0 L = INDEX(LL) IF (BI(L,J)) 620,622,621 620 DSUMN = DSUMN + DBLE(BI(L,J)) GO TO 622 621 DSUMP = DSUMP + DBLE(BI(L,J)) 622 CONTINUE Y(J) = DSUMP + DSUMN S = DSUMP T = DSUMN TOL = RERRMX*AMAX1(S,-T) IF (ABS(Y(J)) .LT. TOL) Y(J) = 0.0 623 CONTINUE GO TO 650 C C SET UP THE R ARRAY FOR THE NSTEP = 2 CASE C 630 IF (N .EQ. NUM) GO TO 680 NSTEP = 2 M0 = 0 DO 631 L = 1,M IF (IBASIS(L) .LE. N) GO TO 631 M0 = M0 + 1 INDEX(M0) = L 631 CONTINUE C DO 643 J = 1,M DSUMP = 0.D0 DSUMN = 0.D0 DO 642 LL = 1,M0 L = INDEX(LL) IF (BI(L,J)) 640,642,641 640 DSUMN = DSUMN + DBLE(BI(L,J)) GO TO 642 641 DSUMP = DSUMP + DBLE(BI(L,J)) 642 CONTINUE Y(J) = -(DSUMP + DSUMN) S = DSUMP T = DSUMN TOL = RERRMX*AMAX1(S,-T) IF (ABS(Y(J)) .LT. TOL) Y(J) = 0.0 643 CONTINUE C 650 DO 652 J = 1,N0 SUM = 0.0 IF (BASIS(J) .NE. 0) GO TO 652 DO 651 L = 1,M IF (A(L,J) .NE. 0.0) SUM = SUM + Y(L)*A(L,J) 651 CONTINUE 652 R(J) = SUM C 660 IF (N0 .EQ. NS) GO TO 670 JMIN = N0 + 1 DO 661 J = JMIN,NS R(J) = 0.0 IF (BASIS(J) .NE. 0) GO TO 661 JJ = J - N0 R(J) = Y(JJ) 661 CONTINUE C 670 IF (NS .EQ. N) GO TO 200 JMIN = NS + 1 DO 671 J = JMIN,N R(J) = 0.0 IF (BASIS(J) .NE. 0) GO TO 671 JJ = J - N0 R(J) = -Y(JJ) 671 CONTINUE GO TO 200 C C SET UP A NEW R ARRAY FOR THE NSTEP = 3 CASE C 680 NSTEP = 3 DO 682 J = 1,M DSUM = 0.D0 DO 681 L = 1,M IL = IBASIS(L) IF (IL .LE. N0) DSUM = DSUM + DBLE(C(IL)*BI(L,J)) 681 CONTINUE 682 Y(J) = DSUM C DO 691 J = 1,N0 R(J) = 0.0 IF (BASIS(J) .NE. 0) GO TO 691 DSUM = -C(J) DO 690 L = 1,M IF (A(L,J) .NE. 0.0) DSUM = DSUM + DBLE(Y(L)*A(L,J)) 690 CONTINUE R(J) = DSUM IF (R(J) .GE. 0.0) GO TO 691 TOL = RERRMX*ABS(C(J)) IF (ABS(R(J)) .LT. TOL) R(J) = 0.0 691 CONTINUE GO TO 660 C C UPDATE THE R ARRAY FOR THE NSTEP = 3 CASE C 700 CONST = R(JP) DO 703 J = 1,N0 IF (BASIS(J) .EQ. 0) GO TO 701 R(J) = 0.0 GO TO 703 701 SUM = 0.0 DO 702 L = 1,M IF (A(L,J) .NE. 0.0) SUM = SUM + BI(IP,L)*A(L,J) 702 CONTINUE R(J) = R(J) - CONST*SUM IF (R(J) .GE. 0.0) GO TO 703 TOL = RERRMX*ABS(C(J)) IF (ABS(R(J)) .LT. TOL) R(J) = 0.0 703 CONTINUE C 710 IF (N0 .EQ. NS) GO TO 720 JMIN = N0 + 1 DO 712 J = JMIN,NS IF (BASIS(J) .EQ. 0) GO TO 711 R(J) = 0.0 GO TO 712 711 JJ = J - N0 R(J) = R(J) - CONST*BI(IP,JJ) 712 CONTINUE C 720 IF (NS .EQ. N) GO TO 200 JMIN = NS + 1 DO 722 J = JMIN,N IF (BASIS(J) .EQ. 0) GO TO 721 R(J) = 0.0 GO TO 722 721 JJ = J - N0 R(J) = R(J) + CONST*BI(IP,JJ) 722 CONTINUE GO TO 200 C----------------------------------------------------------------------- C REFINE XB AND STORE THE RESULT IN Y C----------------------------------------------------------------------- 800 DO 801 I = 1,M Y(I) = 0.0 801 CONTINUE C M0 = 0 DO 831 J = 1,M KJ = IBASIS(J) IF (KJ .LE. N0) GO TO 810 IF (KJ .LE. NS) GO TO 820 IF (KJ .LE. N) GO TO 830 GO TO 820 C 810 M0 = M0 + 1 INDEX(M0) = J GO TO 831 C 820 L = KJ - N0 Y(L) = XB(J) GO TO 831 C 830 L = KJ - N0 Y(L) = -XB(J) 831 CONTINUE C IF (M0 .NE. 0) GO TO 841 DO 840 I = 1,M 840 R(I) = B0(I) - Y(I) GO TO 850 841 DO 843 I = 1,M DSUM = Y(I) DO 842 JJ = 1,M0 J = INDEX(JJ) KJ = IBASIS(J) DSUM = DSUM + DBLE(A(I,KJ)*XB(J)) 842 CONTINUE R(I) = B0(I) - DSUM 843 CONTINUE C 850 RERR1 = AMIN1(RERRMX,RERR) DO 856 I = 1,M Y(I) = 0.0 IF (XB(I)) 851,856,852 851 SGN = -1.0 DSUMP = 0.D0 DSUMN = XB(I) GO TO 853 852 SGN = 1.0 DSUMP = XB(I) DSUMN = 0.D0 853 DO 855 L = 1,M DT = BI(I,L)*R(L) IF (DT .GT. 0.D0) GO TO 854 DSUMN = DSUMN + DT GO TO 855 854 DSUMP = DSUMP + DT 855 CONTINUE W = DSUMP + DSUMN IF (W .EQ. 0.0) GO TO 856 IF (SGN .NE. SIGN(1.0,W)) GO TO 856 S = DSUMP T = DSUMN TOL = RERR1*AMAX1(S,-T) IF (ABS(W) .GT. TOL) Y(I) = W 856 CONTINUE IF (NSTEP - 2) 860,870,880 C C CHECK THE REFINEMENT (NSTEP = 1) C 860 DO 861 I = 1,M IF (Y(I) .GE. 0.0) GO TO 861 IF (Y(I) .LT. -RERRMX) GO TO 240 Y(I) = 0.0 861 XB(I) = Y(I) GO TO 630 C C CHECK THE REFINEMENT (NSTEP = 2) C 870 DO 871 I = 1,M IF (IBASIS(I) .LE. N) GO TO 871 IF (Y(I) .GT. RERRMX) GO TO 240 Y(I) = 0.0 871 XB(I) = Y(I) GO TO 680 C C COMPUTE Z (NSTEP = 3) C 880 DSUM = 0.D0 DO 881 I = 1,M KI = IBASIS(I) IF (KI .GT. N0) GO TO 881 DSUM = DSUM + DBLE(C(KI)*Y(I)) 881 XB(I) = Y(I) Z = DSUM GO TO 220 END SUBROUTINE SSPLX (TA,ITA,JTA,B0,C,M,N0,IND,IBASIS,X,Z,ITER,MXITER, * NUMLE,NUMGE,BI,WK,IWK) C----------------------------------------------------------------------- C SIMPLEX PROCEDURE FOR SOLVING LINEAR PROGRAMMING PROBLEMS C----------------------------------------------------------------------- C WRITTEN BY ALFRED H. MORRIS JR. C NAVAL SURFACE WEAPONS CENTER C DAHLGREN, VIRGINIA C------------------------ C INITIAL VERSION DEC 1977 C LAST UPDATE OCT 1990 C------------------------ DIMENSION TA(*),ITA(*),JTA(*) DIMENSION B0(M),C(N0) DIMENSION IBASIS(M),BI(M,M) DIMENSION X(*),WK(*),IWK(*) C------------------------ C DIMENSION X(N0+NUMLE+NUMGE) C DIMENSION WK(2*M),IWK(2*M+N0) C------------------------ C C ********** EPS0 IS A MACHINE DEPENDENT PARAMETER. ASSIGN EPS0 C THE VALUE U WHERE U IS THE SMALLEST POSITIVE FLOATING C POINT NUMBER SUCH THAT 1.0 + U .GT. 1.0. C EPS0 = SPMPAR(1) C C------------------------ RERRMN = 10.0*EPS0 RERRMX = 1.E-4 IF (EPS0 .LT. 1.E-13) RERRMX = 1.E-5 C IP = M + N0 + 1 CALL SSPLX1(TA,ITA,JTA,B0,C,M,N0,IND,IBASIS,X,Z,ITER,MXITER, 1 EPS0,RERRMN,RERRMX,RERR,NUMLE,NUMGE,BI, 2 WK(1),WK(M+1),IWK(1),IWK(IP)) RETURN END SUBROUTINE SSPLX1 (TA,ITA,JTA,B0,C,M,N0,IND,IBASIS,R,Z, 1 ITER,MXITER,EPS0,RERRMN,RERRMX,RERR,NUMLE,NUMGE, 2 BI,XB,Y,BASIS,INDEX) C---------------------- C NSTEP = 1 ELIMINATE THE NEGATIVE VARIABLES C NSTEP = 2 PHASE 1 OF THE SIMPLEX ALGORITHM C NSTEP = 3 PHASE 2 OF THE SIMPLEX ALGORITHM C---------------------- C MXITER = THE MAXIMUM NUMBER OF ITERATIONS PERMITTED C ITER = THE NUMBER OF THE CURRENT ITERATION C ICOUNT = THE NUMBER OF ITERATIONS SINCE THE LAST INVERSION C---------------------- C NUMLE = THE NUMBER OF .LE. CONSTRAINTS C NUMGE = THE NUMBER OF .GE. CONSTRAINTS C---------------------- C THE ROUTINE ASSUMES THAT THE .LE. CONSTRAINTS PRECEDE THE .GE. C CONSTRAINTS AND THAT THE .EQ. CONSTRAINTS COME LAST. THERE ARE C M CONSTRAINTS. X(N0+I) IS THE SLACK, SURPLUS, OR ARTIFICIAL C VARIABLE FOR THE I-TH CONSTRAINT (I=1,...,M). C---------------------- C N0 = THE NUMBER OF ORGINAL VARIABLES C NS = THE NUMBER OF ORGINAL AND SLACK VARIABLES C N = THE NUMBER OF ORGINAL, SLACK, AND SURPLUS VARIABLES C NUM = THE TOTAL NUMBER OF VARIABLES C---------------------- C RERRMN = THE SMALLEST RELATIVE ERROR TOLERANCE USED C RERRMX = THE LARGEST RELATIVE ERROR TOLERANCE USED C RERR = THE ESTIMATED CURRENT RELATIVE ERROR C---------------------- C LET A DENOTE AN MXN0 MATRIX. THE TRANSPOSE OF A IS STORED IN C SPARSE FORM IN TA,ITA,JTA. ASSUME THAT C B0 = (B0(1),...,B0(M)) C C = (C(1),...,C(N0)) C Z = C(1)*X(1)+...+C(N0)*X(N0) C THE PROBLEM IS TO MAXIMIZE Z SUBJECT TO C AX(LE,EQ,GE)B0 C X.GE.0 C---------------------- C ON INPUT IND CAN HAVE THE VALUES C IND = 0 NO BEGINNING BASIS IS PROVIDED BY THE USER C IND = 1 THE ARRAY IBASIS HAS BEEN SET BY THE USER C ON OUTPUT IND IS ASSIGNED ONE OF THE VALUES C IND = 0 Z WAS SUCCESSFULLY MAXIMIZED C IND = 1 THE PROBLEM HAS NO FEASIBLE SOLUTION C IND = 2 MXITER ITERATIONS WERE PERFORMED C IND = 3 SUFFICIENT ACCURACY CANNOT BE MAINTAINED C IND = 4 THE PROBLEM HAS AN UNBOUNDED SOLUTION C IND = 5 THERE IS AN INPUT ERROR C IND = 6 Z WAS POSSIBLY MAXIMIZED C---------------------- C BASIS IS AN INTEGER ARRAY OF DIMENSION N0+M. FOR J.LE.N C BASIS(J) = 1 IF X(J) IS A BASIC VARIABLE C BASIS(J) = 0 IF X(J) IS NOT A BASIC VARIABLE C IF THE BASIC VARIABLES ARE X(I1),...,X(IM) THEN C IBASIS = (I1,...,IM) C ALSO XB(1),...,XB(M) ARE THE CORRESPONDING VALUES OF THE C BASIC VARIABLES. C---------------------- C BI IS AN MXM ARRAY CONTAINING THE INVERSE OF THE BASIS MATRIX. C---------------------- C R IS AN ARRAY OF DIMENSION N. ON OUTPUT R CONTAINS THE CURRENT C VALUE OF X. DURING COMPUTATION R NORMALLY CONTAINS THE REDUCED C COSTS USED FOR THE SELECTION OF THE VARIABLE TO BE MADE BASIC. C---------------------- REAL TA(*), B0(M), C(N0) REAL BI(M,M), XB(M), Y(M), R(*) INTEGER ITA(*), JTA(*) INTEGER IBASIS(M), BASIS(*) INTEGER BFLAG, INDEX(M) DOUBLE PRECISION DSUM, DSUMP, DSUMN, DT C---------------------- C C ****** XMAX IS A MACHINE DEPENDENT CONSTANT. XMAX IS THE C LARGEST POSITIVE FLOATING POINT NUMBER. C XMAX = SPMPAR(3) C C---------------------- ITER = 0 ICOUNT = 0 MCHECK = MIN0(5,1 + M/15) Z = 0.0 C C CHECK FOR INPUT ERRORS C MS = NUMLE + NUMGE IF (M .LT. 2 .OR. N0 .LT. 2 .OR. MS .GT. M) GO TO 12 DO 10 I = 1,M IF (B0(I) .LT. 0.0) GO TO 12 10 XB(I) = 0.0 RTOL = XMAX DO 11 I = 1,N0 IF (C(I) .NE. 0.0) RTOL = AMIN1(ABS(C(I)),RTOL) 11 CONTINUE RTOL = RERRMX*RTOL GO TO 20 C 12 IND = 5 RETURN C C FORMATION OF THE IBASIS AND BASIS ARRAYS. (IF IND = 1 C THEN THE IBASIS ARRAY IS DEFINED BY THE USER.) C 20 NS = N0 + NUMLE N = NS + NUMGE IF (IND .EQ. 0) GO TO 30 NUM = N DO 21 I = 1,M IF (IBASIS(I) .GT. N) NUM = NUM + 1 21 CONTINUE GO TO 32 22 IF (IND .EQ. 0) GO TO 590 IND = 0 C 30 NUM = N0 + M DO 31 I = 1,M 31 IBASIS(I) = N0 + I 32 BFLAG = 0 DO 33 I = 1,N 33 BASIS(I) = 0 DO 34 I = 1,M KI = IBASIS(I) 34 BASIS(KI) = 1 IF (IND .EQ. 1) GO TO 100 C C CALCULATION OF XB AND BI WHEN IND = 0 C RERR = RERRMN DO 41 J = 1,M XB(J) = B0(J) DO 40 I = 1,M 40 BI(I,J) = 0.0 BI(J,J) = 1.0 41 CONTINUE IF (NUMGE .EQ. 0) GO TO 630 JMIN = NUMLE + 1 DO 42 J = JMIN,MS XB(J) = -XB(J) BI(J,J) = -1.0 42 CONTINUE GO TO 601 C C REORDER THE BASIS C 100 IBEG = 1 IEND = M DO 102 I = 1,M IF (IBASIS(I) .LE. N0) GO TO 101 INDEX(IBEG) = IBASIS(I) IBEG = IBEG + 1 GO TO 102 101 INDEX(IEND) = IBASIS(I) IEND = IEND - 1 102 CONTINUE IF (IEND .EQ. M) GO TO 22 DO 103 I = 1,M 103 IBASIS(I) = INDEX(I) C C REINVERSION OF THE BASIS MATRIX C DO 132 J = 1,M KJ = IBASIS(J) IF (KJ .LE. N0) GO TO 110 IF (KJ .LE. NS) GO TO 120 IF (KJ .LE. N) GO TO 130 GO TO 120 C 110 DO 111 I = 1,M 111 BI(I,J) = 0.0 LMIN = ITA(KJ) LMAX = ITA(KJ + 1) - 1 IF (LMIN .GT. LMAX) GO TO 132 DO 112 LL = LMIN,LMAX L = JTA(LL) 112 BI(L,J) = TA(LL) GO TO 132 C 120 L = KJ - N0 DO 121 I = 1,M 121 BI(I,J) = 0.0 BI(L,J) = 1.0 GO TO 132 C 130 L = KJ - N0 DO 131 I = 1,M 131 BI(I,J) = 0.0 BI(L,J) = -1.0 132 CONTINUE C ICOUNT = 0 CALL CROUT1 (BI, M, M, IEND, INDEX, Y, JCOL, IERR) IF (IERR .NE. 0) GO TO 580 C C CHECK THE ACCURACY OF BI AND RESET RERR C BNORM = 0.0 DO 142 J = 1,M KJ = IBASIS(J) IF (KJ .LE. N0) GO TO 140 SUM = 1.0 GO TO 142 140 SUM = 0.0 LMIN = ITA(KJ) LMAX = ITA(KJ + 1) - 1 DO 141 LL = LMIN,LMAX 141 SUM = SUM + ABS(TA(LL)) 142 BNORM = AMAX1(BNORM,SUM) C BINORM = 0.0 DO 151 J = 1,M SUM = 0.0 DO 150 I = 1,M 150 SUM = SUM + ABS(BI(I,J)) BINORM = AMAX1(BINORM,SUM) 151 CONTINUE RERR = AMAX1(RERRMN,EPS0*BNORM*BINORM) IF (RERR .GT. 1.E-2) GO TO 580 BFLAG = 0 C C RECALCULATION OF XB C 180 DO 183 I = 1,M DSUMP = 0.D0 DSUMN = 0.D0 DO 182 L = 1,M DT = BI(I,L)*B0(L) IF (DT .GT. 0.D0) GO TO 181 DSUMN = DSUMN + DT GO TO 182 181 DSUMP = DSUMP + DT 182 CONTINUE XB(I) = DSUMP + DSUMN S = DSUMP T = DSUMN TOL = RERRMX*AMAX1(S,-T) IF (ABS(XB(I)) .LT. TOL) XB(I) = 0.0 183 CONTINUE GO TO 601 C C FIND THE NEXT VECTOR A(--,JP) TO BE INSERTED INTO C THE BASIS C 200 JP = 0 RMIN = 0.0 IF (NSTEP .EQ. 3) RMIN = -RTOL DO 201 J = 1,N0 IF (BASIS(J) .NE. 0) GO TO 201 IF (R(J) .GE. RMIN) GO TO 201 JP = J RMIN = R(J) 201 CONTINUE IF (N0 .EQ. N) GO TO 203 JMIN = N0 + 1 RMIN = RMIN*1.1 DO 202 J = JMIN,N IF (BASIS(J) .NE. 0) GO TO 202 IF (R(J) .GE. RMIN) GO TO 202 JP = J RMIN = R(J) 202 CONTINUE 203 IF (JP .NE. 0) GO TO 300 IF (NSTEP - 2) 800,230,250 C C INSERT THE VALUES OF THE ORGINAL, SLACK, AND SURPLUS C VARIABLES INTO R. THEN TERMINATE. C 220 DO 221 J = 1,N 221 R(J) = 0.0 DO 222 I = 1,M KI = IBASIS(I) IF (KI .LE. N) R(KI) = XB(I) 222 CONTINUE RETURN C C COMPLETION OF THE NSTEP = 2 CASE C 230 DO 231 I = 1,M IF (IBASIS(I) .LE. N) GO TO 231 IF (XB(I) .GT. 0.0) GO TO 800 231 CONTINUE GO TO 680 C 240 IF (ICOUNT .GE. 5) GO TO 100 IND = 1 GO TO 220 C C COMPLETION OF THE NSTEP = 3 CASE C 250 IF (RERR .GT. 1.E-2) GO TO 251 IND = 0 GO TO 800 251 IF (ICOUNT .GE. 5) GO TO 100 IND = 6 GO TO 800 C C IF MXITER ITERATIONS HAVE NOT BEEN PERFORMED THEN C BEGIN THE NEXT ITERATION. COMPUTE THE JP-TH COLUMN C OF BI*A AND STORE IT IN Y. C 300 IF (ITER .LT. MXITER) GO TO 301 IND = 2 GO TO 220 301 ITER = ITER + 1 ICOUNT = ICOUNT + 1 IF (JP .GT. NS) GO TO 330 IF (JP .GT. N0) GO TO 320 C LMIN = ITA(JP) LMAX = ITA(JP + 1) - 1 IF (LMIN .LE. LMAX) GO TO 305 IND = 4 GO TO 220 305 AMAX = 0.0 DO 306 LL = LMIN,LMAX AMAX = AMAX1(ABS(TA(LL)),AMAX) 306 CONTINUE C 310 RERR1 = RERRMX*AMAX DO 313 I = 1,M DSUM = 0.D0 DO 311 LL = LMIN,LMAX L = JTA(LL) DSUM = DSUM + DBLE(BI(I,L)*TA(LL)) 311 CONTINUE Y(I) = DSUM IF (ABS(Y(I)) .GE. 5.E-3) GO TO 313 BMAX = 0.0 DO 312 L = 1,M BMAX = AMAX1(ABS(BI(I,L)),BMAX) 312 CONTINUE TOL = RERR1*BMAX IF (ABS(Y(I)) .LT. TOL) Y(I) = 0.0 313 CONTINUE GO TO 350 C 320 L = JP - N0 DO 321 I = 1,M Y(I) = BI(I,L) 321 CONTINUE GO TO 350 C 330 L = JP - N0 DO 331 I = 1,M Y(I) = -BI(I,L) 331 CONTINUE C 350 DO 351 I = 1,M IF (Y(I) .NE. 0.0) GO TO 360 351 CONTINUE R(JP) = 0.0 ITER = ITER - 1 ICOUNT = ICOUNT - 1 GO TO 200 C 360 IF (NSTEP - 2) 400,430,440 C C FINDING THE VARIABLE XB(IP) TO BE MADE NONBASIC C FOR THE NSTEP = 1 CASE C 400 NPOS = 0 IP = 0 EPS = 0.0 EPSI = XMAX DO 403 I = 1,M IF (XB(I) .LT. 0.0 .OR. Y(I) .LE. 0.0) GO TO 403 RATIO = XB(I)/Y(I) IF (RATIO - EPSI) 401,402,403 401 EPSI = RATIO NPOS = 1 INDEX(1) = I GO TO 403 402 NPOS = NPOS + 1 INDEX(NPOS) = I 403 CONTINUE IF (NPOS .EQ. 0) GO TO 420 IF (EPSI .EQ. 0.0) GO TO 460 C DO 410 I = 1,M IF (XB(I) .GE. 0.0 .OR. Y(I) .GE. 0.0) GO TO 410 RATIO = XB(I)/Y(I) IF (RATIO .GT. EPSI) GO TO 410 IF (RATIO .LT. EPS) GO TO 410 EPS = RATIO IP = I 410 CONTINUE IF (IP .NE. 0) GO TO 500 GO TO 460 C 420 DO 421 I = 1,M IF (XB(I) .GE. 0.0 .OR. Y(I) .GE. 0.0) GO TO 421 RATIO = XB(I)/Y(I) IF (RATIO .LT. EPS) GO TO 421 EPS = RATIO IP = I 421 CONTINUE GO TO 500 C C FINDING THE VARIABLE XB(IP) TO BE MADE NONBASIC C FOR THE NSTEP = 2 CASE C 430 NPOS = 0 EPSI = XMAX DO 433 I = 1,M IF (Y(I) .LE. 0.0) GO TO 433 RATIO = XB(I)/Y(I) IF (RATIO - EPSI) 431,432,433 431 EPSI = RATIO NPOS = 1 INDEX(1) = I GO TO 433 432 NPOS = NPOS + 1 INDEX(NPOS) = I 433 CONTINUE GO TO 450 C C FINDING THE VARIABLE XB(IP) TO BE MADE NONBASIC C FOR THE NSTEP = 3 CASE C 440 NPOS = 0 EPSI = XMAX DO 445 I = 1,M IF (Y(I)) 441,445,442 441 IF (IBASIS(I) .LE. N) GO TO 445 IP = I GO TO 500 442 RATIO = XB(I)/Y(I) IF (RATIO - EPSI) 443,444,445 443 EPSI = RATIO NPOS = 1 INDEX(1) = I GO TO 445 444 NPOS = NPOS + 1 INDEX(NPOS) = I 445 CONTINUE C 450 IF (NPOS .NE. 0) GO TO 460 IF (ICOUNT .GE. 5) GO TO 100 IND = 4 GO TO 220 C C TIE BREAKING PROCEDURE C 460 IP = INDEX(1) IF (NPOS .EQ. 1) GO TO 500 IP = 0 BMIN = XMAX CMIN = XMAX DO 464 II = 1,NPOS I = INDEX(II) L = IBASIS(I) IF (L .GT. N0) GO TO 461 IF (C(L) .LE. 0.0) CMIN = AMIN1(0.0,CMIN) IF (C(L) .GT. CMIN) GO TO 464 IMIN = I CMIN = C(L) GO TO 464 461 IF (L .LE. N) GO TO 462 IP = I GO TO 500 462 LROW = L - N0 S = B0(LROW) IF (LROW .GT. NUMLE) GO TO 463 IF (S .GT. BMIN) GO TO 464 IP = I BMIN = S GO TO 464 463 S = -S BMIN = AMIN1(0.0,BMIN) IF (S .GT. BMIN) GO TO 464 IP = I BMIN = S 464 CONTINUE IF (CMIN .LE. 0.0 .OR. IP .EQ. 0) IP = IMIN C C TRANSFORMATION OF XB C 500 IF (XB(IP) .EQ. 0.0) GO TO 510 CONST = XB(IP)/Y(IP) DO 501 I = 1,M S = XB(I) XB(I) = XB(I) - CONST*Y(I) IF (XB(I) .GE. 0.0) GO TO 501 IF (S .GE. 0.0 .OR. XB(I) .GE. RERRMX*S) XB(I) = 0.0 501 CONTINUE XB(IP) = CONST C C TRANSFORMATION OF BI C 510 DO 512 J = 1,M IF (BI(IP,J) .EQ. 0.0) GO TO 512 CONST = BI(IP,J)/Y(IP) DO 511 I = 1,M 511 BI(I,J) = BI(I,J) - CONST*Y(I) BI(IP,J) = CONST 512 CONTINUE C C UPDATING IBASIS AND BASIS C IOUT = IBASIS(IP) IBASIS(IP) = JP BASIS(IOUT) = 0 BASIS(JP) = 1 IF (IOUT .GT. N) NUM = NUM - 1 C C CHECK THE ACCURACY OF BI AND RESET RERR C IF (RERR .GT. 1.E-2) GO TO 530 K = 0 DO 521 J = 1,M KJ = IBASIS(J) IF (KJ .GT. N0) GO TO 521 SUM = 0.0 LMIN = ITA(KJ) LMAX = ITA(KJ + 1) - 1 DO 520 LL = LMIN,LMAX L = JTA(LL) SUM = SUM + BI(J,L)*TA(LL) 520 CONTINUE RERR = AMAX1(RERR,ABS(1.0-SUM)) K = K + 1 IF (K .GE. MCHECK) GO TO 522 521 CONTINUE 522 IF (RERR .LE. 1.E-2) GO TO 600 C C THE ACCURACY CRITERIA ARE NOT SATISFIED C 530 IF (ICOUNT .LT. 5) GO TO 600 BFLAG = 1 GO TO 100 C 580 IF (ITER .EQ. 0) GO TO 12 IF (BFLAG .EQ. 0) GO TO 590 BFLAG = 0 DO 581 IP = 1,M IF (JP .EQ. IBASIS(IP)) GO TO 582 581 CONTINUE 582 IBASIS(IP) = IOUT BASIS(JP) = 0 BASIS(IOUT) = 1 IF (IOUT .GT. N) NUM = NUM + 1 GO TO 100 C 590 IND = 3 GO TO 220 C C SET UP THE R ARRAY FOR THE NSTEP = 1 CASE C 600 IF (NSTEP - 2) 601,630,700 601 DO 602 J = 1,M IF (XB(J) .LT. 0.0) GO TO 610 602 CONTINUE GO TO 630 C 610 NSTEP = 1 M0 = 0 DO 611 L = 1,M IF (XB(L) .GE. 0.0) GO TO 611 M0 = M0 + 1 INDEX(M0) = L 611 CONTINUE C DO 623 J = 1,M DSUMP = 0.D0 DSUMN = 0.D0 DO 622 LL = 1,M0 L = INDEX(LL) IF (BI(L,J)) 620,622,621 620 DSUMN = DSUMN + DBLE(BI(L,J)) GO TO 622 621 DSUMP = DSUMP + DBLE(BI(L,J)) 622 CONTINUE Y(J) = DSUMP + DSUMN S = DSUMP T = DSUMN TOL = RERRMX*AMAX1(S,-T) IF (ABS(Y(J)) .LT. TOL) Y(J) = 0.0 623 CONTINUE GO TO 650 C C SET UP THE R ARRAY FOR THE NSTEP = 2 CASE C 630 IF (N .EQ. NUM) GO TO 680 NSTEP = 2 M0 = 0 DO 631 L = 1,M IF (IBASIS(L) .LE. N) GO TO 631 M0 = M0 + 1 INDEX(M0) = L 631 CONTINUE C DO 643 J = 1,M DSUMP = 0.D0 DSUMN = 0.D0 DO 642 LL = 1,M0 L = INDEX(LL) IF (BI(L,J)) 640,642,641 640 DSUMN = DSUMN + DBLE(BI(L,J)) GO TO 642 641 DSUMP = DSUMP + DBLE(BI(L,J)) 642 CONTINUE Y(J) = -(DSUMP + DSUMN) S = DSUMP T = DSUMN TOL = RERRMX*AMAX1(S,-T) IF (ABS(Y(J)) .LT. TOL) Y(J) = 0.0 643 CONTINUE C 650 DO 652 J = 1,N0 SUM = 0.0 IF (BASIS(J) .NE. 0) GO TO 652 LMIN = ITA(J) LMAX = ITA(J + 1) - 1 IF (LMIN .GT. LMAX) GO TO 652 DO 651 LL = LMIN,LMAX L = JTA(LL) SUM = SUM + Y(L)*TA(LL) 651 CONTINUE 652 R(J)=SUM C 660 IF (N0 .EQ. NS) GO TO 670 JMIN = N0 + 1 DO 661 J = JMIN,NS R(J) = 0.0 IF (BASIS(J) .NE. 0) GO TO 661 JJ = J - N0 R(J) = Y(JJ) 661 CONTINUE C 670 IF (NS .EQ. N) GO TO 200 JMIN = NS + 1 DO 671 J = JMIN,N R(J) = 0.0 IF (BASIS(J) .NE. 0) GO TO 671 JJ = J - N0 R(J) = -Y(JJ) 671 CONTINUE GO TO 200 C C SET UP A NEW R ARRAY FOR THE NSTEP = 3 CASE C 680 NSTEP = 3 DO 682 J = 1,M DSUM = 0.D0 DO 681 L = 1,M IL = IBASIS(L) IF (IL .LE. N0) DSUM = DSUM + DBLE(C(IL)*BI(L,J)) 681 CONTINUE 682 Y(J) = DSUM C DO 691 J = 1,N0 R(J) = 0.0 IF (BASIS(J) .NE. 0) GO TO 691 DSUM = -C(J) LMIN = ITA(J) LMAX = ITA(J + 1) - 1 R(J) = -C(J) IF (LMIN .GT. LMAX) GO TO 691 DO 690 LL = LMIN,LMAX L = JTA(LL) DSUM = DSUM + DBLE(Y(L)*TA(LL)) 690 CONTINUE R(J) = DSUM IF (R(J) .GE. 0.0) GO TO 691 TOL = RERRMX*ABS(C(J)) IF (ABS(R(J)) .LT. TOL) R(J) = 0.0 691 CONTINUE GO TO 660 C C UPDATE THE R ARRAY FOR THE NSTEP = 3 CASE C 700 CONST = R(JP) DO 703 J = 1,N0 IF (BASIS(J) .EQ. 0) GO TO 701 R(J) = 0.0 GO TO 703 701 SUM = 0.0 LMIN = ITA(J) LMAX = ITA(J + 1) - 1 IF (LMIN .GT. LMAX) GO TO 703 DO 702 LL = LMIN,LMAX L = JTA(LL) SUM = SUM + BI(IP,L)*TA(LL) 702 CONTINUE R(J) = R(J) - CONST*SUM IF (R(J) .GE. 0.0) GO TO 703 TOL = RERRMX*ABS(C(J)) IF (ABS(R(J)) .LT. TOL) R(J) = 0.0 703 CONTINUE C 710 IF (N0 .EQ. NS) GO TO 720 JMIN = N0 + 1 DO 712 J = JMIN,NS IF (BASIS(J) .EQ. 0) GO TO 711 R(J) = 0.0 GO TO 712 711 JJ = J - N0 R(J) = R(J) - CONST*BI(IP,JJ) 712 CONTINUE C 720 IF (NS .EQ. N) GO TO 200 JMIN = NS + 1 DO 722 J = JMIN,N IF (BASIS(J) .EQ. 0) GO TO 721 R(J) = 0.0 GO TO 722 721 JJ = J - N0 R(J) = R(J) + CONST*BI(IP,JJ) 722 CONTINUE GO TO 200 C----------------------------------------------------------------------- C REFINE XB AND STORE THE RESULT IN Y C----------------------------------------------------------------------- 800 DO 801 I = 1,M R(I) = 0.0 Y(I) = 0.0 801 CONTINUE C DO 831 J = 1,M KJ = IBASIS(J) IF (KJ .LE. N0) GO TO 810 IF (KJ .LE. NS) GO TO 820 IF (KJ .LE. N) GO TO 830 GO TO 820 C 810 LMIN = ITA(KJ) LMAX = ITA(KJ + 1) - 1 DO 811 LL = LMIN,LMAX L = JTA(LL) DT = DBLE(R(L)) + DBLE(Y(L)) DT = DT + DBLE(TA(LL)*XB(J)) R(L) = DT Y(L) = DT - DBLE(R(L)) 811 CONTINUE GO TO 831 C 820 L = KJ - N0 DT = DBLE(R(L)) + DBLE(Y(L)) DT = DT + DBLE(XB(J)) R(L) = DT Y(L) = DT - DBLE(R(L)) GO TO 831 C 830 L = KJ - N0 DT = DBLE(R(L)) + DBLE(Y(L)) DT = DT - DBLE(XB(J)) R(L) = DT Y(L) = DT - DBLE(R(L)) 831 CONTINUE C DO 840 I = 1,M DT = DBLE(R(I)) + DBLE(Y(I)) R(I) = DBLE(B0(I)) - DT 840 CONTINUE C 850 RERR1 = AMIN1(RERRMX,RERR) DO 856 I = 1,M Y(I) = 0.0 IF (XB(I)) 851,856,852 851 SGN = -1.0 DSUMP = 0.D0 DSUMN = XB(I) GO TO 853 852 SGN = 1.0 DSUMP = XB(I) DSUMN = 0.D0 853 DO 855 L = 1,M DT = BI(I,L)*R(L) IF (DT .GT. 0.D0) GO TO 854 DSUMN = DSUMN + DT GO TO 855 854 DSUMP = DSUMP + DT 855 CONTINUE W = DSUMP + DSUMN IF (W .EQ. 0.0) GO TO 856 IF (SGN .NE. SIGN(1.0,W)) GO TO 856 S = DSUMP T = DSUMN TOL = RERR1*AMAX1(S,-T) IF (ABS(W) .GT. TOL) Y(I) = W 856 CONTINUE IF (NSTEP - 2) 860,870,880 C C CHECK THE REFINEMENT (NSTEP = 1) C 860 DO 861 I = 1,M IF (Y(I) .GE. 0.0) GO TO 861 IF (Y(I) .LT. -RERRMX) GO TO 240 Y(I) = 0.0 861 XB(I) = Y(I) GO TO 630 C C CHECK THE REFINEMENT (NSTEP = 2) C 870 DO 871 I = 1,M IF (IBASIS(I) .LE. N) GO TO 871 IF (Y(I) .GT. RERRMX) GO TO 240 Y(I) = 0.0 871 XB(I) = Y(I) GO TO 680 C C COMPUTE Z (NSTEP = 3) C 880 DSUM = 0.D0 DO 881 I = 1,M KI = IBASIS(I) IF (KI .GT. N0) GO TO 881 DSUM = DSUM + DBLE(C(KI)*Y(I)) 881 XB(I) = Y(I) Z = DSUM GO TO 220 END SUBROUTINE CROUT1(A,KA,N,IEND,INDEX,TEMP,JP,IERR) C ****************************************************************** C CROUT PROCEDURE FOR INVERTING MATRICES C ****************************************************************** C A IS A MATRIX OF ORDER N WHERE N IS GREATER THAN OR EQUAL TO 1. C THE INVERSE OF A IS COMPUTED AND STORED IN A. C C KA = LENGTH OF THE COLUMNS OF THE ARRAY A C JP = THE NUMBER OF THE COLUMN THAT CONTAINS THE SMALLEST PIVOT C C IEND MAY BE 0,1,...,N-1. IT IS ASSUMED THAT EACH OF THE FIRST C IEND COLUMNS OF THE MATRIX A CONTAINS ONLY ONE NONZERO ELEMENT C AND THAT THE NONZERO ELEMENT IS 1 OR -1. C C INDEX IS AN ARRAY OF DIMENSION N-1 OR LARGER THAT IS USED BY THE C ROUTINE FOR KEEPING TRACK OF THE ROW INTERCHANGES THAT ARE MADE. C C TEMP IS A TEMPORARY STORAGE ARRAY. C C IERR REPORTS THE STATUS OF THE RESULTS. IF A IS NONSINGULAR THEN C THE INVERSE OF A IS COMPUTED AND IERR=0. OTHERWISE IF A IS FOUND C TO BE SINGULAR THEN IERR=1 AND THE ROUTINE TERMINATES. C -------------------- DIMENSION A(*),INDEX(*),TEMP(N) DOUBLE PRECISION DSUM MAX = KA*N MCOL = IEND*KA IF (IEND .EQ. 0) GO TO 100 C C PROCESS THE FIRST IEND COLUMNS OF A C KCOL = 0 DO 32 K = 1,IEND KK = KCOL + K NK = KCOL + N DO 10 LK = KK,NK IF (A(LK)) 20,10,30 10 CONTINUE JP = K GO TO 300 C 20 L = LK - KCOL LJ0 = MCOL + L DO 21 LJ = LJ0,MAX,KA 21 A(LJ) = -A(LJ) C 30 L = LK - KCOL INDEX(K) = L IF (K .EQ. L) GO TO 32 LJ = LK DO 31 KJ = KK,MAX,KA C = A(KJ) A(KJ) = A(LJ) A(LJ) = C 31 LJ = LJ + KA 32 KCOL = KCOL + KA C C PROCESS THE REMAINING COLUMNS OF A C 100 NM1 = N - 1 JP = 1 IERR = 0 PMIN = 0.0 IBEG = IEND + 1 IF (IBEG .EQ. N) GO TO 190 C K = IBEG KM1 = IEND KP1 = K + 1 KCOL = MCOL KK = KCOL + K DO 172 KCOUNT = IBEG,NM1 C C SEARCH FOR THE K-TH PIVOT ELEMENT (K=IBEG,...,N-1) C L = K S = ABS(A(KK)) DO 110 I = KP1,N IK = KCOL + I C = ABS(A(IK)) IF (S .GE. C) GO TO 110 L = I S = C 110 CONTINUE C IF (K.GT.IBEG .AND. S.GE.PMIN) GO TO 120 JP = K PMIN = S IF (S .EQ. 0.0) GO TO 300 C C INTERCHANGING ROWS K AND L C 120 INDEX(K) = L IF (K .EQ. L) GO TO 130 KJ0 = MCOL + K LJ = MCOL + L DO 121 KJ = KJ0,MAX,KA C = A(KJ) A(KJ) = A(LJ) A(LJ) = C 121 LJ = LJ + KA C C COMPUTE THE K-TH ROW OF U (K=IBEG,...,N-1) C 130 C = A(KK) IF (K .GT. IBEG) GO TO 140 KJ0 = KK + KA DO 131 KJ = KJ0,MAX,KA 131 A(KJ) = A(KJ)/C GO TO 160 C 140 KL = MCOL + K DO 141 L = IBEG,KM1 TEMP(L) = A(KL) 141 KL = KL + KA C KJ0 = KK + KA DO 151 KJ = KJ0,MAX,KA JCOL = KJ - K DSUM = -A(KJ) DO 150 L = IBEG,KM1 LJ = JCOL + L 150 DSUM = DSUM + DBLE(TEMP(L))*DBLE(A(LJ)) 151 A(KJ) = SNGL(-DSUM)/C C C COMPUTE THE K-TH COLUMN OF L (K=IBEG+1,...,N) C 160 KM1 = K K = KP1 KP1 = K + 1 KCOL = KCOL + KA KK = KCOL + K DO 161 L = IBEG,KM1 LK = KCOL + L 161 TEMP(L) = A(LK) C DO 171 I = K,N IL = MCOL + I DSUM = 0.D0 DO 170 L = IBEG,KM1 DSUM = DSUM + DBLE(A(IL))*DBLE(TEMP(L)) 170 IL = IL + KA 171 A(IL) = DBLE(A(IL)) - DSUM 172 CONTINUE C C CHECK THE N-TH PIVOT ELEMENT C 190 NCOL = MAX - KA NN = NCOL + N C = ABS(A(NN)) IF (C .GT. PMIN) GO TO 200 JP = N IF (C .EQ. 0.0) GO TO 300 C C REPLACE L WITH THE INVERSE OF L C 200 IF (IBEG .EQ. N) GO TO 213 JJ = MCOL + IBEG I = KA + 1 DO 212 J = IBEG,NM1 A(JJ) = 1.0/A(JJ) TEMP(J) = A(JJ) KJ = JJ DO 211 KM1 = J,NM1 K = KM1 + 1 KJ = KJ + 1 DSUM = 0.D0 KL = KJ DO 210 L = J,KM1 DSUM = DSUM + DBLE(A(KL)*TEMP(L)) 210 KL = KL + KA A(KJ) = SNGL(-DSUM)/A(KL) 211 TEMP(K) = A(KJ) 212 JJ = JJ + I 213 A(NN) = 1.0/A(NN) IF (N .EQ. 1) RETURN C C SOLVE UX = Y WHERE Y IS THE INVERSE OF L C DO 242 NMK = 1,NM1 K = N - NMK LMIN = MAX0(IBEG,K+1) KL = (LMIN-1)*KA + K DO 230 L = LMIN,N TEMP(L) = A(KL) A(KL) = 0.0 230 KL = KL + KA C KJ0 = MCOL + K DO 241 KJ = KJ0,MAX,KA DSUM = -A(KJ) LJ = (KJ - K) + LMIN DO 240 L = LMIN,N DSUM = DSUM + DBLE(TEMP(L)*A(LJ)) 240 LJ = LJ + 1 241 A(KJ) = -DSUM 242 CONTINUE C C COLUMN INTERCHANGES C JCOL = NCOL - KA DO 251 NMJ = 1,NM1 J = N - NMJ K = INDEX(J) IF (J .EQ. K) GO TO 251 IJ = JCOL IK = (K-1)*KA DO 250 I = 1,N IJ = IJ + 1 IK = IK + 1 C = A(IJ) A(IJ) = A(IK) 250 A(IK) = C 251 JCOL = JCOL - KA RETURN C C ERROR RETURN C 300 IERR = 1 RETURN END SUBROUTINE ASSGN (N,A,C,T,IWK,IERR) C ------------------- C SOLUTION OF THE ASSIGNMENT PROBLEM C ------------------- INTEGER A(N,*), C(N), T, IWK(*) C I1 = N + 1 I2 = I1 + N I3 = I2 + N I4 = I3 + N + 1 I5 = I4 + N I6 = I5 + N CALL ASSGN1(N,A,C,T,IWK(1),IWK(I1),IWK(I2),IWK(I3),IWK(1), * IWK(I3),IWK(I4),IWK(I5),IWK(I6),IERR) RETURN END SUBROUTINE ASSGN1(N,A,C,T,CH,LC,LR,LZ,NZ,RH,SLC,SLR, * U,IERR) INTEGER A(N,*), C(N), CH(N), LC(N), LR(N), LZ(N), * NZ(N), RH(*), SLC(N), SLR(N), U(*) INTEGER H, Q, R, S, T C C THIS SUBROUTINE SOLVES THE SQUARE ASSIGNMENT PROBLEM C THE MEANING OF THE INPUT PARAMETERS IS C N = NUMBER OF ROWS AND COLUMNS OF THE COST MATRIX C A(I,J) = ELEMENT IN ROW I AND COLUMN J OF THE COST MATRIX C ( AT THE END OF COMPUTATION THE ELEMENTS OF A ARE CHANGED) C THE MEANING OF THE OUTPUT PARAMETERS IS C C(J) = ROW ASSIGNED TO COLUMN J (J=1,N) C T = COST OF THE OPTIMAL ASSIGNMENT C ALL PARAMETERS ARE INTEGER C THE MEANING OF THE LOCAL VARIABLES IS C A(I,J) = ELEMENT OF THE COST MATRIX IF A(I,J) IS POSITIVE, C COLUMN OF THE UNASSIGNED ZERO FOLLOWING IN ROW I C (I=1,N) THE UNASSIGNED ZERO OF COLUMN J (J=1,N) C IF A(I,J) IS NOT POSITIVE C A(I,N+1) = COLUMN OF THE FIRST UNASSIGNED ZERO OF ROW I C (I=1,N) C CH(I) = COLUMN OF THE NEXT UNEXPLORED AND UNASSIGNED ZERO C OF ROW I (I=1,N) C LC(J) = LABEL OF COLUMN J (J=1,N) C LR(I) = LABEL OF ROW I (I=1,N) C LZ(I) = COLUMN OF THE LAST UNASSIGNED ZERO OF ROW I(I=1,N) C NZ(I) = COLUMN OF THE NEXT UNASSIGNED ZERO OF ROW I(I=1,N) C RH(I) = UNEXPLORED ROW FOLLOWING THE UNEXPLORED ROW I C (I=1,N) C RH(N+1) = FIRST UNEXPLORED ROW C SLC(K) = K-TH ELEMENT CONTAINED IN THE SET OF THE LABELLED C COLUMNS C SLR(K) = K-TH ELEMENT CONTAINED IN THE SET OF THE LABELLED C ROWS C U(I) = UNASSIGNED ROW FOLLOWING THE UNASSIGNED ROW I C (I=1,N) C U(N+1) = FIRST UNASSIGNED ROW C IERR = 0 IF THE ROUTINE TERMINATES SUCCESSFULLY. OTHERWISE C IERR = 1 C C THE VECTORS C,CH,LC,LR,LZ,NZ,SLC,SLR MUST BE DIMENSIONED C AT LEAST AT (N), THE VECTORS RH,U AT LEAST AT (N+1), C AND THE MATRIX A AT LEAST AT (N,N+1). TO SAVE STORAGE C LZ AND RH MAY USE THE SAME STORAGE AREA, AND NZ AND CH C MAY USE THE SAME STORAGE AREA. C C INITIALIZATION MAXNUM = IPMPAR(3) IERR = 0 NP1 = N+1 DO 10 J=1,N C(J) = 0 LZ(J) = 0 NZ(J) = 0 U(J) = 0 10 CONTINUE U(NP1) = 0 T = 0 C REDUCTION OF THE INITIAL COST MATRIX DO 40 J=1,N S = A(1,J) DO 15 L=2,N IF ( A(L,J) .LT. S ) S = A(L,J) 15 CONTINUE IF (S) 20,40,30 20 MM = MAXNUM + S IF (T .LT. -MM) GO TO 400 T = T + S DO 25 I = 1,N IF (A(I,J) .GT. MM) GO TO 400 A(I,J) = A(I,J) - S 25 CONTINUE GO TO 40 30 MM = MAXNUM - S IF (T .GT. MM) GO TO 400 T = T + S DO 35 I = 1,N A(I,J) = A(I,J) - S 35 CONTINUE 40 CONTINUE DO 70 I=1,N Q = A(I,1) DO 50 L=2,N IF ( A(I,L) .LT. Q ) Q = A(I,L) 50 CONTINUE MM = MAXNUM - Q IF (T .GT. MM) GO TO 400 T = T + Q L = NP1 DO 60 J=1,N A(I,J) = A(I,J)-Q IF ( A(I,J) .NE. 0 ) GO TO 60 A(I,L) = -J L = J 60 CONTINUE 70 CONTINUE C CHOICE OF THE INITIAL SOLUTION K = NP1 DO 140 I=1,N LJ = NP1 J = -A(I,NP1) 80 IF ( C(J) .EQ. 0 ) GO TO 130 LJ = J J = -A(I,J) IF ( J .NE. 0 ) GO TO 80 LJ = NP1 J = -A(I,NP1) 90 R = C(J) LM = LZ(R) M = NZ(R) 100 IF ( M .EQ. 0 ) GO TO 110 IF ( C(M) .EQ. 0 ) GO TO 120 LM = M M = -A(R,M) GO TO 100 110 LJ = J J = -A(I,J) IF ( J .NE. 0 ) GO TO 90 U(K) = I K = I GO TO 140 120 NZ(R) = -A(R,M) LZ(R) = J A(R,LM) = -J A(R,J) = A(R,M) A(R,M) = 0 C(M) = R 130 C(J) = I A(I,LJ) = A(I,J) NZ(I) = -A(I,J) LZ(I) = LJ A(I,J) = 0 140 CONTINUE C RESEARCH OF A NEW ASSIGNMENT 150 IF ( U(NP1) .EQ. 0 ) RETURN DO 160 I=1,N CH(I) = 0 LC(I) = 0 LR(I) = 0 RH(I) = 0 160 CONTINUE RH(NP1) = -1 KSLC = 0 KSLR = 1 R = U(NP1) LR(R) = -1 SLR(1) = R IF ( A(R,NP1) .EQ. 0 ) GO TO 220 170 L = -A(R,NP1) IF ( A(R,L) .EQ. 0 ) GO TO 180 IF ( RH(R) .NE. 0 ) GO TO 180 RH(R) = RH(NP1) CH(R) = -A(R,L) RH(NP1) = R 180 IF ( LC(L) .EQ. 0 ) GO TO 200 IF ( RH(R) .EQ. 0 ) GO TO 210 190 L = CH(R) CH(R) = -A(R,L) IF ( A(R,L) .NE. 0 ) GO TO 180 RH(NP1) = RH(R) RH(R) = 0 GO TO 180 200 LC(L) = R IF ( C(L) .EQ. 0 ) GO TO 360 KSLC = KSLC+1 SLC(KSLC) = L R = C(L) LR(R) = L KSLR = KSLR+1 SLR(KSLR) = R IF ( A(R,NP1) .NE. 0 ) GO TO 170 210 CONTINUE IF ( RH(NP1) .GT. 0 ) GO TO 350 C REDUCTION OF THE CURRENT COST MATRIX 220 H = MAXNUM DO 240 J=1,N IF ( LC(J) .NE. 0 ) GO TO 240 DO 230 K=1,KSLR I = SLR(K) IF ( A(I,J) .LT. H ) H = A(I,J) 230 CONTINUE 240 CONTINUE MM = MAXNUM - H IF (MM .EQ. 0 .OR. T .GT. MM) GO TO 400 T = T + H DO 290 J=1,N IF ( LC(J) .NE. 0 ) GO TO 290 DO 280 K=1,KSLR I = SLR(K) A(I,J) = A(I,J)-H IF ( A(I,J) .NE. 0 ) GO TO 280 IF ( RH(I) .NE. 0 ) GO TO 250 RH(I) = RH(NP1) CH(I) = J RH(NP1) = I 250 L = NP1 260 NL = -A(I,L) IF ( NL .EQ. 0 ) GO TO 270 L = NL GO TO 260 270 A(I,L) = -J 280 CONTINUE 290 CONTINUE IF ( KSLC .EQ. 0 ) GO TO 350 DO 340 I=1,N IF ( LR(I) .NE. 0 ) GO TO 340 DO 330 K=1,KSLC J = SLC(K) IF ( A(I,J) .GT. 0 ) GO TO 320 L = NP1 300 NL = - A(I,L) IF ( NL .EQ. J ) GO TO 310 L = NL GO TO 300 310 A(I,L) = A(I,J) A(I,J) = H GO TO 330 320 MM = MAXNUM - H IF (A(I,J) .GT. MM) GO TO 400 A(I,J) = A(I,J) + H 330 CONTINUE 340 CONTINUE 350 R = RH(NP1) GO TO 190 C ASSIGNMENT OF A NEW ROW 360 C(L) = R M = NP1 370 NM = -A(R,M) IF ( NM .EQ. L ) GO TO 380 M = NM GO TO 370 380 A(R,M) = A(R,L) A(R,L) = 0 IF ( LR(R) .LT. 0 ) GO TO 390 L = LR(R) A(R,L) = A(R,NP1) A(R,NP1) = -L R = LC(L) GO TO 360 390 U(NP1) = U(R) U(R) = 0 GO TO 150 C ERROR RETURN - INTEGER OVERFLOW OCCURS 400 IERR = 1 RETURN END SUBROUTINE MKP (N,M,P,W,K,BCK,XSTAR,VSTAR,WK,IWK,NUM) C C SUBROUTINE TO SOLVE A 0-1 MULTIPLE KNAPSACK PROBLEM OF N C ITEMS (WITH N .GE. 2) AND M KNAPSACKS (WITH M .GE. 1 , C I.E. ALSO SUITABLE FOR A 0-1 SINGLE KNAPSACK PROBLEM). C THE PROBLEM TO BE SOLVED IS C C MAXIMIZE VSTAR = P(1)*(X(1,1) + ... + X(M,1)) + ... C ... + P(N)*(X(1,N) + ... + X(M,N)) C SUBJECT TO C W(1)*X(I,1) + ... + W(N)*X(I,N) .LE. K(I) FOR I=1,...,M C X(1,J) + ... + X(M,J) .LE. 1 FOR J=1,...,N C X(I,J) = 0 OR 1 FOR I=1,...,M , J=1,...,N , C C WHERE ALL P(J), W(J), AND K(I) ARE POSITIVE INTEGERS. C BEFORE MKP IS CALLED, ARRAY K MUST BE SORTED SO THAT C K(1) .LE. K(2) .LE. ... .LE. K(M) . C C MEANING OF THE INPUT PARAMETERS ... C C N = NUMBER OF ITEMS. C M = NUMBER OF KNAPSACKS. C P(J) = PROFIT OF ITEM J (J=1,...,N) . C W(J) = WEIGHT OF ITEM J (J=1,...,N) . C K(I) = CAPACITY OF KNAPSACK I (I=1,...,M) . C BCK = -1 IF EXACT SOLUTION IS REQUIRED. C = MAXIMUM NUMBER OF BACKTRACKINGS TO BE PERFORMED, IF C HEURISTIC SOLUTION IS REQUIRED. C WK = REAL WORK SPACE OF DIMENSION N. C IWK = WORK SPACE OF DIMENSION .GE. 5*M + 14*N + 4*M*N + 3 C NUM = DIMENSION OF IWK C C MEANING OF THE OUTPUT PARAMETERS ... C C XSTAR(J) = 0 IF ITEM J IS NOT IN THE OPTIMAL SOLUTION C (I.E. IF X(I,J) = 0 FOR ALL I ). C = KNAPSACK WHERE ITEM J IS INSERTED, OTHERWISE C (I.E. IF X(XSTAR(J),J) = 1 ). C VSTAR = VALUE OF THE OPTIMAL SOLUTION IF VSTAR .GT. 0. C = ERROR CONDITION (INFEASIBILITY OR TRIVIALITY) C IN THE INPUT DATA IF VSTAR .LT. 0 . C = -1 IF N .LT. 2 OR M .LT. 1 . C = -2 IF SOME P(J) , W(J) OR K(I) ARE NOT C POSITIVE. C = -3 IF A KNAPSACK CANNOT CONTAIN ANY ITEM. C = -4 IF AN ITEM CANNOT FIT INTO ANY KNAPSACK. C = -5 IF KNAPSACK M CONTAINS ALL THE ITEMS. C = -7 IF ARRAY K IS NOT CORRECTLY SORTED. C = -8 IF NUM .LT. 5*M + 14*N + 4*M*N + 3. C C (IN ALL THE ABOVE CASES ARRAY XSTAR IS NOT C DEFINED). C C ALL THE PARAMETERS EXCEPT WK ARE OF INTEGER TYPE. WHEN MKP C TERMINATES, ALL THE INPUT PARAMETERS ARE UNCHANGED EXCEPT C BCK, WHICH GIVES THE NUMBER OF BACKTRACKINGS PERFORMED. C INTEGER P(N),W(N),K(M),XSTAR(N),BCK,VSTAR,IWK(NUM) REAL WK(N) INTEGER BB, BL, X, XL INTEGER B, UBB INTEGER F, PBL, Q, V INTEGER BS, PS, WS, XS C C CHECK THE INPUT DATA C IF (M .LT. 1 .OR. N .LT. 2) GO TO 100 MN = M*N IF (NUM .LT. 5*M + 14*N + 4*MN + 3) GO TO 160 C IF (P(1) .LE. 0 .OR. W(1) .LE. 0) GO TO 110 AP = P(1) AW = W(1) WK(1) = -AP/AW MAXW = W(1) MINW = W(1) ISUMW = W(1) DO 10 J = 2,N IF (P(J) .LE. 0 .OR. W(J) .LE. 0) GO TO 110 AP = P(J) AW = W(J) WK(J) = -AP/AW IF (W(J) .GT. MAXW) MAXW = W(J) IF (W(J) .LT. MINW) MINW = W(J) ISUMW = ISUMW + W(J) 10 CONTINUE C IF (K(1) .LE. 0) GO TO 110 IF (M .EQ. 1) GO TO 30 DO 20 I = 2,M IF (K(I) .LE. 0) GO TO 110 IF (K(I) .LT. K(I-1)) GO TO 150 20 CONTINUE C 30 IF (MINW .GT. K(1)) GO TO 120 IF (MAXW .GT. K(M)) GO TO 130 IF (ISUMW .LE. K(M)) GO TO 140 VSTAR = 0 C C REORDER THE ARRAYS P AND W SO THAT C P(J)/W(J) .GE. P(J+1)/W(J+1) C N5 = 5*N DO 40 J = 1,N JJ = N5 + J IWK(JJ) = J 40 CONTINUE CALL RISORT (WK, IWK(N5 + 1), N) C DO 50 J = 1,N IWK(J) = P(J) JN = J + N IWK(JN) = W(J) 50 CONTINUE C DO 60 J = 1,N JJ = N5 + J L = IWK(JJ) P(J) = IWK(L) NPL = N + L W(J) = IWK(NPL) 60 CONTINUE C C PARTITION THE WORK SPACE IWK C LX = JJ + 1 LXI = LX + N BS = LXI + N XS = BS + N UBB = XS + N C NP1 = N + 1 B = UBB + N PS = B + NP1 WS = PS + NP1 C F = WS + NP1 PBL = F + M Q = PBL + M V = Q + M C BB = V + M X = BB + MN XL = X + MN C BL = XL + MN C C SOLVE THE PROBLEM C CALL MKP1 (N, M, P, W, K, BCK, XSTAR, VSTAR, NP1, N5, 1 IWK(BB), IWK(BL), IWK(X), IWK(XL), 2 IWK(B), IWK(UBB), IWK(LX), IWK(LXI), 3 IWK(F), IWK(PBL), IWK(Q), IWK(V), 4 IWK(BS), IWK(PS), IWK(WS), IWK(XS), IWK(1)) C C RESTORE THE INITIAL ORDERING TO P AND W, C AND REORDER XSTAR ACCORDINGLY C DO 70 J = 1,N IWK(J) = P(J) JN = J + N IWK(JN) = W(J) JNN = JN + N IWK(JNN) = XSTAR(J) 70 CONTINUE C DO 80 J = 1,N JJ = N5 + J L = IWK(JJ) P(L) = IWK(J) JN = J + N W(L) = IWK(JN) JNN = JN + N XSTAR(L) = IWK(JNN) 80 CONTINUE RETURN C C ERROR RETURN C 100 VSTAR = -1 RETURN 110 VSTAR = -2 RETURN 120 VSTAR = -3 RETURN 130 VSTAR = -4 RETURN 140 VSTAR = -5 RETURN 150 VSTAR = -7 RETURN 160 VSTAR = -8 RETURN END SUBROUTINE MKP1 (N, M, P, W, K, BCK, XSTAR, VSTAR, NP1, N5, 1 BB, BL, X, XL, B, UBB, LX, LXI, 2 F, PBL, Q, V, BS, PS, WS, XS, IWK) C C MEANING OF THE MAIN INTERNAL VARIABLES AND ARRAYS ... C C I = KNAPSACK CURRENTLY CONSIDERED. C LB = LOWER BOUND ON THE OPTIMAL SOLUTION. C UB = UPPER BOUND ON THE OPTIMAL SOLUTION. C VB = VALUE OF THE CURRENT SOLUTION. C X(I,J) = 1 IF ITEM J IS INSERTED IN KNAPSACK I IN C THE CURRENT SOLUTION. C = 0 OTHERWISE. C F(I) = POINTER TO THE LAST ITEM INSERTED IN KNAPSACK I C ( = -1 IF KNAPSACK I IS EMPTY). C BB(I,J) = POINTER TO THE ITEM INSERTED IN KNAPSACK I C JUST BEFORE ITEM J ( = -1 IF J IS THE FIRST C ITEM INSERTED IN KNAPSACK I ). C Q(I) = CURRENT AVAILABLE CAPACITY OF KNAPSACK I . C B(J) = 1 IF ITEM J IS NOT INSERTED IN ANY KNAPSACK. C = 0 IF ITEM J IS INSERTED IN A KNAPSACK. C PBL(I) = NUMBER OF THE ITEMS WHICH CAN BE INSERTED IN C KNAPSACK I . C BL(I,S) = POINTER TO THE S-TH ITEM WHICH CAN BE INSERTED C IN KNAPSACK I . C XL(I,J) = 1 IF ITEM J WAS INSERTED IN KNAPSACK I IN C THE LAST EXECUTION OF SUBROUTINE PI1. C = 0 OTHERWISE. C IWK WORK SPACE FOR THE SUBROUTINE SKNP. C INTEGER P(N), W(N), K(M), XSTAR(N), BCK, VSTAR INTEGER BB(M,N), BL(M,NP1), X(M,N), XL(M,N) INTEGER B(NP1), UBB(N), LX(N), LXI(N) INTEGER F(M), PBL(M), Q(M), V(M) INTEGER BS(N), PS(NP1), WS(NP1), XS(N), IWK(N5) INTEGER S, U, UB, VB C IF (M .EQ. 1) GO TO 250 C C STEP 1 (INITIALIZATION) C JBCK = BCK BCK = 0 KUB = 0 N1 = N + 1 B(N1) = 1 M1 = M - 1 DO 40 J=1,N B(J) = 1 DO 30 I=1,M X(I,J) = 0 BB(I,J) = 0 30 CONTINUE 40 CONTINUE DO 50 I=1,M1 Q(I) = K(I) F(I) = -1 50 CONTINUE Q(M) = K(M) VSTAR = 0 VB = 0 I = 1 CALL SIGMA1 (N,M,P,W,K,1,B,KUB,UB,NP1,N5,LX,LR, * BS,PS,WS,XS,IWK) DO 60 J=1,N LXI(J) = LX(J) 60 CONTINUE LRI = LR LUBI = UB IFLAG = 0 C C STEP 2 (HEURISTIC) C 70 KUB = VSTAR - VB CALL PI1 (N,M,P,W,Q,I,B,BB,KUB,BL,LB,PBL,V,XL, * NP1,N5,BS,PS,WS,XS,IWK) IF ( LB + VB .LE. VSTAR ) GO TO 140 VSTAR = LB + VB DO 90 J=1,N XSTAR(J) = 0 DO 80 S=1,I IF ( X(S,J) .EQ. 0 ) GO TO 80 XSTAR(J) = S GO TO 90 80 CONTINUE 90 CONTINUE IP = PBL(I) IF ( IP .EQ. 0 ) GO TO 110 DO 100 J=1,IP JJ = BL(I,J) IF ( XL(I,J) .EQ. 1 ) XSTAR(JJ) = I 100 CONTINUE 110 I1 = I + 1 DO 130 II=I1,M IP = PBL(II) IF ( IP .EQ. 0 ) GO TO 130 DO 120 J=1,IP JJ = BL(II,J) IF ( XL(II,J) .EQ. 1 ) XSTAR(JJ) = II 120 CONTINUE 130 CONTINUE IF ( UB .EQ. LB ) GO TO 200 C C STEP 3 (UPDATING) C 140 IF ( V(I) .EQ. 0 ) GO TO 180 IUV = UB + VB U = PBL(I) IBV = 0 DO 170 S=1,U IF ( XL(I,S) .EQ. 0 ) GO TO 170 J = BL(I,S) X(I,J) = 1 Q(I) = Q(I) - W(J) VB = VB + P(J) B(J) = 0 BB(I,J) = F(I) UBB(J) = IUV IF ( IFLAG .EQ. 1 ) GO TO 150 LUB = IUV LJ = J LI = I 150 F(I) = J IBV = IBV + P(J) IF ( IBV .EQ. V(I) ) GO TO 180 CALL PARC (I,I,UB,IFLAG,VB,LUB,LJ,LI,F,BB,Q,B,N,M,NP1, * LX,LXI,LR,LRI,LUBI) IF ( IFLAG .EQ. 1 ) GO TO 160 KUB = VSTAR - VB CALL SIGMA1 (N,M,P,W,Q,I,B,KUB,UB,NP1,N5,LX,LR, * BS,PS,WS,XS,IWK) LJ = N1 160 IUV = UB + VB IF ( IUV .LE. VSTAR ) GO TO 200 170 CONTINUE 180 IF ( I .EQ. M - 1 ) GO TO 200 IP1 = I + 1 CALL PARC (IP1,I,UB,IFLAG,VB,LUB,LJ,LI,F,BB,Q,B,N,M,NP1, * LX,LXI,LR,LRI,LUBI) IF ( IFLAG .EQ. 1 ) GO TO 190 KUB = VSTAR - VB CALL SIGMA1 (N,M,P,W,Q,IP1,B,KUB,UB,NP1,N5,LX,LR, * BS,PS,WS,XS,IWK) LJ = N1 190 IF ( UB + VB .LE. VSTAR ) GO TO 200 I = I + 1 GO TO 140 C C STEP 4 (BACKTRACKING) C 200 IF ( I .GT. 0 ) GO TO 210 BCK = BCK - 1 RETURN 210 IF ( BCK .EQ. JBCK ) RETURN BCK = BCK + 1 IF ( F(I) .NE. (-1) ) GO TO 230 DO 220 J=1,N BB(I,J) = 0 220 CONTINUE I = I - 1 GO TO 200 230 J = F(I) X(I,J) = 0 B(J) = 1 VB = VB - P(J) Q(I) = Q(I) + W(J) DO 240 S=1,N IF ( BB(I,S) .EQ. J ) BB(I,S) = 0 240 CONTINUE F(I) = BB(I,J) IF ( UBB(J) .LE. VSTAR ) GO TO 200 UB = UBB(J) - VB IFLAG = 1 GO TO 70 C C PARTICULAR CASE (0-1 SINGLE KNAPSACK PROBLEM) C 250 K1 = K(1) DO 260 J=1,N PS(J) = P(J) WS(J) = W(J) 260 CONTINUE CALL SKNP (N,K1,0,VSTAR,N,NP1,N5,PS,WS,XS,IWK) DO 270 J=1,N XSTAR(J) = XS(J) 270 CONTINUE BCK = 0 RETURN END SUBROUTINE SIGMA1 (N,M,P,W,Q,I,B,KUB,UB,NP1,N5,LX,LR, * BS,PS,WS,XS,IWK) C C SUBROUTINE TO COMPUTE AN UPPER BOUND UB ON THE BEST C FINAL SOLUTION WHICH CAN BE OBTAINED FROM THE CURRENT C SOLUTION. C INTEGER P(N),W(N),Q(M),B(NP1),UB,IWK(N5) INTEGER LX(N),BS(N),PS(NP1),WS(NP1),XS(N) INTEGER QS,SB C NS = 0 QS = 0 DO 10 J=I,M QS = QS + Q(J) 10 CONTINUE SB = 0 DO 20 J=1,N LX(J) = 0 IF ( B(J) .EQ. 0 ) GO TO 20 NS = NS + 1 BS(NS) = J PS(NS) = P(J) WS(NS) = W(J) SB = SB + W(J) 20 CONTINUE IF ( SB .GT. QS ) GO TO 40 LR = QS - SB UB = 0 IF ( NS .EQ. 0 ) RETURN DO 30 J=1,NS UB = UB + PS(J) XS(J) = 1 30 CONTINUE GO TO 50 40 CALL SKNP (NS,QS,KUB,UB,N,NP1,N5,PS,WS,XS,IWK) LR = QS 50 DO 60 J=1,NS JJ = BS(J) LX(JJ) = XS(J) 60 CONTINUE RETURN END SUBROUTINE PI1 (N,M,P,W,Q,I,B,BB,KUB,BL,LB,PBL,V,XL, * NP1,N5,BS,PS,WS,XS,IWK) C C SUBROUTINE TO COMPUTE A FEASIBLE SOLUTION TO THE CURRENT C PROBLEM. THE SOLUTION IS STORED IN ARRAY XL , THE C CORRESPONDING VALUE IN LB . C INTEGER BB(M,N),BL(M,NP1),XL(M,N),IWK(N5) INTEGER P(N),W(N),Q(M),B(NP1),PBL(M),V(M) INTEGER BS(N),PS(NP1),WS(NP1),XS(N) INTEGER PB,QS,SB,U C C STEP 1 C U = 0 DO 10 J=1,N IF ( B(J) .EQ. 0 ) GO TO 10 U = U + 1 BS(U) = J 10 CONTINUE DO 20 J=I,M PBL(J) = 0 V(J) = 0 20 CONTINUE LB = 0 IKUB = KUB IF ( U .EQ. 0 ) RETURN NS = 0 SB = 0 DO 30 J=1,U JJ = BS(J) IF ( BB(I,JJ) .NE. 0 ) GO TO 30 IF ( W(JJ) .GT. Q(I) ) GO TO 30 NS = NS + 1 SB = SB + W(JJ) BL(I,NS) = JJ PS(NS) = P(JJ) WS(NS) = W(JJ) 30 CONTINUE II = I C C STEP 2 C 40 PBL(II) = NS IF ( SB .GT. Q(II) ) GO TO 60 PB = 0 IF ( NS .EQ. 0 ) GO TO 80 DO 50 J=1,NS PB = PB + PS(J) XL(II,J) = 1 50 CONTINUE GO TO 80 60 QS = Q(II) KUB = 0 IF ( II .EQ. M ) KUB = IKUB CALL SKNP (NS,QS,KUB,PB,N,NP1,N5,PS,WS,XS,IWK) DO 70 J=1,NS XL(II,J) = XS(J) 70 CONTINUE 80 LB = LB + PB IKUB = IKUB - PB V(II) = PB BL(II,NS+1) = N + 1 C C STEP 3 C IF ( II .EQ. M ) RETURN JB = 1 JBS = 0 DO 100 J=1,U IF ( BS(J) .LT. BL(II,JB) ) GO TO 90 JB = JB + 1 IF ( XL(II,JB-1) .EQ. 1 ) GO TO 100 90 JBS = JBS + 1 BS(JBS) = BS(J) 100 CONTINUE U = JBS IF ( U .EQ. 0 ) RETURN NS = 0 SB = 0 II = II + 1 DO 110 J=1,U JJ = BS(J) IF( W(JJ) .GT. Q(II) ) GO TO 110 NS = NS + 1 SB = SB + W(JJ) BL(II,NS) = JJ PS(NS) = P(JJ) WS(NS) = W(JJ) 110 CONTINUE GO TO 40 END SUBROUTINE PARC (I,II,UB,IFLAG,VB,LUB,LJ,LI,F,BB,Q,B,N,M,NP1, * LX,LXI,LR,LRI,LUBI) C C SUBROUTINE FOR PARAMETRIC COMPUTATION OF THE UPPER BOUNDS. C INTEGER F(M),BB(M,N),Q(M),B(NP1),UB,VB,R,S INTEGER LX(N),LXI(N) C IFLAG = 0 IF ( B(LJ) .NE. 0 ) GO TO 60 I1 = I - 1 IF ( I1 .LT. LI ) GO TO 20 IQ = 0 DO 10 R=LI,I1 IQ = IQ + Q(R) 10 CONTINUE IF ( IQ .GT. LR ) RETURN 20 R = II S = F(R) 30 IF ( S .NE. (-1) ) GO TO 40 R = R - 1 S = F(R) GO TO 30 40 IF ( LX(S) .EQ. 0 ) RETURN IF ( S .EQ. LJ ) GO TO 50 S = BB(R,S) GO TO 30 50 UB = LUB - VB IFLAG = 1 RETURN 60 I1 = I - 1 IF ( I1 .LT. 1 ) GO TO 80 IQ = 0 DO 70 R=1,I1 IQ = IQ + Q(R) 70 CONTINUE IF ( IQ .GT. LRI ) RETURN 80 DO 90 J=1,N IF ( B(J) .EQ. 1 ) GO TO 90 IF ( LXI(J) .EQ. 0 ) RETURN 90 CONTINUE UB = LUBI - VB IFLAG = 1 RETURN END SUBROUTINE SKNP (NS,QS,KUB,VS,N,NP1,N5,PS,WS,XS,IWK) C C SUBROUTINE TO SOLVE THE 0-1 SINGLE KNAPSACK PROBLEM C C MAXIMIZE VS = PS(1)*XS(1) + ... + PS(NS)*XS(NS) C SUBJECT TO WS(1)*XS(1) + ... + WS(NS)*XS(NS) .LE. QS C XS(J) = 0 OR 1 FOR J=1,...,NS C VS .GT. KUB C C THIS SUBROUTINE IS A MODIFIED VERSION OF SUBROUTINE KP01 C WHICH APPEARED IN COMPUTING 21, 81-86(1978). C INTEGER QS, VS INTEGER PS(NP1), WS(NP1), XS(N), IWK(N5) C I1 = 1 I2 = I1 + N I3 = I2 + N I4 = I3 + N I5 = I4 + N CALL SKNP1 (NS,QS,KUB,VS,N,NP1,PS,WS,XS,IWK(I1),IWK(I2), * IWK(I3),IWK(I4),IWK(I5)) RETURN END SUBROUTINE SKNP1 (NS,QS,KUB,VS,N,NP1,PS,WS,XS,D,MIN, * PBAR,WBAR,ZBAR) C C SUBROUTINE TO SOLVE THE 0-1 SINGLE KNAPSACK PROBLEM C C MAXIMIZE VS = PS(1)*XS(1) + ... + PS(NS)*XS(NS) C SUBJECT TO WS(1)*XS(1) + ... + WS(NS)*XS(NS) .LE. QS C XS(J) = 0 OR 1 FOR J=1,...,NS C VS .GT. KUB C C THIS SUBROUTINE IS A MODIFIED VERSION OF SUBROUTINE KP01 C WHICH APPEARED IN COMPUTING 21, 81-86(1978). C INTEGER QS,VS,DIFF,PR,R,T INTEGER PS(NP1),WS(NP1),XS(N) INTEGER D(N),MIN(N),PBAR(N),WBAR(N),ZBAR(N) C VS = KUB IP = 0 MS = QS DO 10 L=1,NS LL = L IF ( WS(L) .GT. MS ) GO TO 20 IP = IP + PS(L) MS = MS - WS(L) 10 CONTINUE 20 LL = LL - 1 IF ( MS .EQ. 0 ) GO TO 50 PS(NS+1) = 0 WS(NS+1) = QS + 1 LIM = IP + (MS*PS(LL+2))/WS(LL+2) A = IP + PS(LL+1) B = (WS(LL+1) - MS)*PS(LL) C = WS(LL) LIM1 = A - B/C IF ( LIM1 .GT. LIM ) LIM = LIM1 IF ( LIM .LE. VS ) RETURN MINK = QS + 1 MIN(NS) = MINK DO 30 J=2,NS KK = NS + 2 - J IF ( WS(KK) .LT. MINK ) MINK = WS(KK) MIN(KK-1) = MINK 30 CONTINUE DO 40 J=1,NS D(J) = 0 40 CONTINUE PR = 0 LOLD = NS II = 1 GO TO 170 50 IF ( VS .GE. IP ) RETURN VS = IP DO 60 J=1,LL XS(J) = 1 60 CONTINUE NN = LL + 1 DO 70 J=NN,NS XS(J) = 0 70 CONTINUE QS = 0 RETURN 80 IF ( WS(II) .LE. QS ) GO TO 90 II1 = II + 1 IF ( VS .GE. (QS*PS(II1))/WS(II1) + PR ) GO TO 280 II = II1 GO TO 80 90 IP = PBAR(II) MS = QS - WBAR(II) IN = ZBAR(II) LL = NS IF ( IN .GT. NS) GO TO 110 DO 100 L=IN,NS LL = L IF ( WS(L) .GT. MS ) GO TO 160 IP = IP + PS(L) MS = MS - WS(L) 100 CONTINUE 110 IF ( VS .GE. IP + PR ) GO TO 280 VS = IP + PR MFIRST = MS NN = II - 1 DO 120 J=1,NN XS(J) = D(J) 120 CONTINUE DO 130 J=II,LL XS(J) = 1 130 CONTINUE IF ( LL .EQ. NS ) GO TO 150 NN = LL + 1 DO 140 J=NN,NS XS(J) = 0 140 CONTINUE 150 IF ( VS .NE. LIM ) GO TO 280 QS = MFIRST RETURN 160 L = LL LL = LL - 1 IF ( MS .EQ. 0 ) GO TO 110 IF ( VS .GE. PR + IP + (MS*PS(L))/WS(L) ) GO TO 280 170 WBAR(II) = QS - MS PBAR(II) = IP ZBAR(II) = LL + 1 D(II) = 1 NN = LL - 1 IF ( NN .LT. II ) GO TO 190 DO 180 J=II,NN WBAR(J+1) = WBAR(J) - WS(J) PBAR(J+1) = PBAR(J) - PS(J) ZBAR(J+1) = LL + 1 D(J+1) = 1 180 CONTINUE 190 J1 = LL + 1 DO 200 J=J1,LOLD WBAR(J) = 0 PBAR(J) = 0 ZBAR(J) = J 200 CONTINUE LOLD = LL QS = MS PR = PR + IP IF ( LL - (NS - 2) ) 240, 220, 210 210 II = NS GO TO 250 220 IF ( QS .LT. WS(NS) ) GO TO 230 QS = QS - WS(NS) PR = PR + PS(NS) D(NS) = 1 230 II = NS - 1 GO TO 250 240 II = LL + 2 IF ( QS .GE. MIN(II-1) ) GO TO 80 250 IF ( VS .GE. PR ) GO TO 270 VS = PR DO 260 J=1,NS XS(J) = D(J) 260 CONTINUE MFIRST = QS IF ( VS .EQ. LIM ) RETURN 270 IF ( D(NS) .EQ. 0 ) GO TO 280 D(NS) = 0 QS = QS + WS(NS) PR = PR - PS(NS) 280 NN = II - 1 IF ( NN .EQ. 0 ) GO TO 300 DO 290 J=1,NN KK = II - J IF ( D(KK) .EQ. 1 ) GO TO 310 290 CONTINUE 300 QS = MFIRST RETURN 310 R = QS QS = QS + WS(KK) PR = PR - PS(KK) D(KK) = 0 IF ( R .LT. MIN(KK) ) GO TO 320 II = KK + 1 GO TO 80 320 NN = KK + 1 II = KK 330 IF ( VS .GE. PR + (QS*PS(NN))/WS(NN) ) GO TO 280 DIFF = WS(NN) - WS(KK) IF ( DIFF ) 390, 340, 350 340 NN = NN + 1 GO TO 330 350 IF ( DIFF .GT. R ) GO TO 340 IF ( VS .GE. PR + PS(NN) ) GO TO 340 VS = PR + PS(NN) DO 360 J=1,KK XS(J) = D(J) 360 CONTINUE JJ = KK + 1 DO 370 J=JJ,NS XS(J) = 0 370 CONTINUE XS(NN) = 1 MFIRST = QS - WS(NN) IF ( VS .NE. LIM ) GO TO 380 QS = MFIRST RETURN 380 R = R - DIFF KK = NN NN = NN + 1 GO TO 330 390 T = R - DIFF IF ( T .LT. MIN(NN) ) GO TO 340 N1 = NN + 1 IF ( VS .GE. PR + PS(NN) + (T*PS(N1))/WS(N1) ) GO TO 280 QS = QS - WS(NN) PR = PR + PS(NN) D(NN) = 1 II = NN + 1 WBAR(NN) = WS(NN) PBAR(NN) = PS(NN) ZBAR(NN) = II DO 400 J=N1,LOLD WBAR(J) = 0 PBAR(J) = 0 ZBAR(J) = J 400 CONTINUE LOLD = NN GO TO 80 END SUBROUTINE LAINV (MO,FUN,T,AERR,RERR,Y,C,ERROR,NUM,IERR) C----------------------------------------------------------------------- C C COMPUTATION OF THE INVERSE LAPLACE TRANSFORM C OF A FUNCTION WHICH IS NOT TOO OSCILLATORY C C ------------------ C C MO IS AN INPUT INTEGER WHICH SPECIFIES THE SEARCH PROCEDURE C FOR DETERMINATION OF C. A TWO-PASS PROCEDURE IS USED WHEN C MO = 0 , AND A ONE-PASS PROCEDURE IS USED WHEN MO IS NOT ZERO. C WHEN ALL SINGULARITIES OF F(Z) ARE EXPECTED TO BE REAL, MO = 0 C IS PREFERABLE. C C FUN IS A REAL SUBROUTINE DEFINED BY THE USER. THE ACTUAL NAME C FOR FUN NEEDS TO BE DECLARED EXTERNAL IN THE DRIVER PROGRAM. C FUN HAS THE ARGUMENTS X, Y, A, AND B. C C T IS A POSITIVE VALUE OF THE INDEPENDENT VARIABLE FOR WHICH C THE INVERSE LAPLACE TRANSFORM IS TO BE CALCULATED. C C C IS THE ABSCISSA OF CONVERGENCE. IT MAY BE EITHER GIVEN C OR CALCULATED BY LAINV. C C Y IS THE CALCULATED VALUE OF THE INVERSE LAPLACE TRANSFORM. C C AERR IS THE ABSOLUTE ACCURACY REQUESTED. C RERR IS THE RELATIVE ACCURACY REQUESTED. THE SUBROUTINE C ATTEMPTS TO SATISFY THE LESS STRINGENT OF THE TWO REQUIREMENTS. C IT IS ASSUMED THAT AERR AND RERR ARE .GE. 0. IF ONE WANTS C ACCURACY TO K SIGNIFICANT FIGURES, THEN RERR SHOULD BE C SET = 10.0**(-K). C C ERROR IS THE ESTIMATED ABSOLUTE ERROR OF Y. C C NUM IS THE NUMBER OF EVALUATIONS OF FUN IN LAINV. C C IERR MAY BE EITHER AN INPUT INTEGER OR AN OUTPUT INTEGER. WHEN C IERR IS EQUAL TO ANY NEGATIVE INTEGER AT THE BEGINNING OF LAINV, C THE ABSCISSA OF CONVERGENCE IS CALCULATED AND THE VALUE OBTAINED C IS ASSIGNED TO THE ARGUMENT C. OTHERWISE, C MUST BE INPUT BY C THE USER. AFTER COMPLETION OF LAINV, IERR HAS ONE OF THE C FOLLOWING VALUES... C C IERR = 0 THE CALCULATION WAS SUCCESSFUL. C C IERR = 1 THE CALCULATED VALUE OF Y MAY NOT BE ACCURATE C DUE TO POSSIBLE INACCURACY IN THE CALCULATION C OF C. THIS VALUE OF IERR MAY OCCUR ONLY WHEN C IERR IS INITIALLY NEGATIVE. C C IERR = 2 THE CALCULATION OF Y DID NOT CONVERGE, WHILE C THE GIVEN OR CALCULATED VALUE OF C MAY BE C CONSIDERED ACCURATE. C C IERR = 3 THE CALCULATION OF Y DID NOT CONVERGE, AND THE C CALCULATED VALUE OF C MAY BE INACCURATE. THIS C VALUE OF IERR MAY OCCUR ONLY WHEN IERR IS C INITIALLY NEGATIVE. C C IERR = 4 THE VALUE OF T IS LESS THAN OR EQUAL TO 0. C THE SPECIAL VALUES Y = 0.0 AND ERROR = 1.0 C ARE ASSIGNED. C C IERR = 5 C WAS NOT FOUND IN THE INTERVAL (-1.0E4,1.0E4). C THE SPECIAL VALUES C = 0.0, Y = 0.0, AND C ERROR = 1.0 ARE ASSIGNED. C THIS VALUE OF IERR MAY OCCUR ONLY WHEN C IERR IS INITIALLY NEGATIVE. C C IERR = 6 T IS TOO LARGE FOR THE INVERSE TRANSFORM TO BE C COMPUTED. THE VALUES Y = 0.0 AND ERROR = 1.0 C ARE ASSIGNED. C C----------------------------------------------------------------------- EXTERNAL FUN C NUM = 0 IERC = -1 IF (IERR .GE. 0) GO TO 10 C C CALCULATION OF THE ABSCISSA OF CONVERGENCE. C IF (MO .EQ. 0) GO TO 5 CALL ABCON1 (FUN,C,NUM,IERC) GO TO 10 5 CALL ABCON (FUN,C,NUM,IERC) 10 IF (IERC .EQ. 2) GO TO 100 C C CHECK IF T IS TOO LARGE C A = C + 2.0/T IF (A*T .GT. EXPARG(0)) GO TO 110 C C CALCULATION OF THE INVERSE LAPLACE TRANSFORM. C CALL LAINV1 (FUN,T,C,RERR,AERR,Y,ERROR,NUM1,IER) NUM = NUM + NUM1 C C REPORT THE STATUS OF THE RESULTS. C IF (IERC .GE. 0) GO TO 20 IF (IER .EQ. 0) GO TO 30 IF (IER .EQ. 1) GO TO 50 20 IF (IER .EQ. 2) GO TO 80 IF (IER .EQ. 1) GO TO 60 IF (IERC .EQ. 1) GO TO 40 C 30 IERR = 0 RETURN 40 IERR = 1 RETURN 50 IERR = 2 RETURN 60 IF (IERC .EQ. 1) GO TO 70 IERR = 2 RETURN 70 IERR = 3 RETURN 80 IERR = 4 RETURN C 100 Y = 0.0 ERROR = 1.0 IERR = 5 RETURN 110 Y = 0.0 ERROR = 1.0 IERR = 6 RETURN END SUBROUTINE ABCON (FUN, C, NUM, IERR) C----------------------------------------------------------------------- C C COMPUTATION OF THE ABSCISSA OF CONVERGENCE C OF A FUNCTION WHICH IS NOT TOO OSCILLATORY C C ----------------- C C FUN IS A REAL SUBROUTINE DEFINED BY THE USER. THE ACTUAL NAME C FOR FUN NEEDS TO BE DECLARED EXTERNAL IN THE DRIVER PROGRAM. C FUN HAS THE ARGUMENTS X, Y, A, AND B. C C C IS THE CALCULATED VALUE OF THE ABSCISSA OF CONVERGENCE. C C NUM IS A VARIABLE. ON OUTPUT IT HAS FOR ITS VALUE THE NUMBER C OF EVALUATIONS OF FUN THAT WERE PERFORMED. C C IERR IS AN OUTPUT INTEGER REPORTING THE STATUS OF THE C CALCULATION OF C. IERR IS ASSIGNED VALUES AS FOLLOWS... C C IERR = 0 THE CALCULATION WAS SUCCESSFUL. C C IERR = 1 THE REQUESTED ACCURACY MAY NOT HAVE BEEN C OBTAINED. MORE SUBINTERVALS MAY BE REQUIRED C IN THE NUMERICAL QUADRATURES IN SUBROUTINES C ACOND AND XCOND. C C IERR = 2 C COULD NOT BE CALCULATED WITH SUFFICIENT C ACCURACY, OR AN INTERVAL CONTAINING C COULD C NOT BE FOUND. THE SPECIAL VALUE C = 0.0 IS C ASSIGNED. C C----------------------------------------------------------------------- LOGICAL FIND EXTERNAL FUN, ACOND, XCOND C ETA = 0.01 XMIN = -1.00358E4 C C CALCULATION OF THE LOCATION OF THE SINGULARITY ON THE REAL C AXIS WHICH IS FARTHEST TO THE RIGHT. SET THIS VALUE TO X0. C CALL SRCH(FUN, XCOND, XMIN, ETA, X0, NUM, IERR) C = X0 IF (IERR .EQ. 2) GO TO 20 IF (IERR .EQ. 3) GO TO 10 C C CHECK IF X0 IS ON THE RIGHT OR LEFT OF THE ABSCISSA OF C CONVERGENCE. IF IT IS ON THE RIGHT THEN WE ARE DONE. C CALL ACOND(FUN, X0, FIND, NUM1, IERR) NUM = NUM + NUM1 IF (FIND) GO TO 20 C C SEARCH TO THE RIGHT OF X0 TO FIND THE ABSCISSA OF C CONVERGENCE. C 10 CALL SRCH(FUN, ACOND, X0, ETA, C, NUM1, IERR) NUM = NUM + NUM1 IF (IERR .EQ. 3) C = 0.0 C C TERMINATION C 20 IERR = MIN0(IERR,2) RETURN END SUBROUTINE SRCH (FUN,COND,XL,ETA,X,NUM,IERR) C----------------------------------------------------------------------- C SRCH COMPUTES AN UPPER BOUND FOR THE SMALLEST NUMBER X SUCH C THAT A GIVEN CONDITION IS SATISFIED. IT IS ASSUMED THAT THE C CONDITION IS SATISFIED FOR SUFFICIENTLY LARGE X. C----------------------------------------------------------------------- C FUN IS A REAL SUBROUTINE DEFINED BY THE USER. THE ACTUAL NAME C FOR FUN NEEDS TO BE DECLARED EXTERNAL IN THE DRIVER PROGRAM. C FUN HAS THE ARGUMENTS X, Y, A, AND B. C C COND IS A REAL SUBROUTINE DEFINED BY THE USER. THE ACTUAL NAME C FOR COND NEEDS TO BE DECLARED EXTERNAL IN THE DRIVER PROGRAM. C COND HAS THE ARGUMENTS FUN, X, CND, AND IER, WHERE CND IS C A LOGICAL VARIABLE. C C XL IS THE SMALLEST VALUE OF X FOR WHICH A SEARCH IS MADE. IT C SHOULD LIE IN THE RANGE - 1.0E4 .LE. XL .LT. 1.0E4. IT IS C ASSUMED THAT THE LOGICAL VARIABLE CND CALCULATED BY COND IS C .FALSE. WHEN X = XL. C C ETA IS THE RELATIVE TOLERANCE TO WHICH THE RESULT IS TO BE C DETERMINED. IT IS A POSITIVE REAL NUMBER. WHEN THIS SUBROUTINE C IS USED TO CALCULATE C FOR USE IN THE PIESSENS CODE LAINV1 C (ALGORITHM 619), IT IS USUALLY SUFFICIENT TO TAKE ETA = 0.01. C C X IS THE CALCULATED RESULT. IT IS LARGER THAN THE EXACT C RESULT BY AN AMOUNT LESS THAN ETA*X. C C NUM IS A VARIABLE. ON OUTPUT IT HAS FOR ITS VALUE THE NUMBER C OF EVALUATIONS OF FUN THAT WERE PERFORMED. C C IERR IS AN OUTPUT INTEGER REPORTING THE STATUS OF THE C CALCULATION OF X. IERR IS ASSIGNED VALUES AS FOLLOWS... C C IERR = 0 THE CALCULATION WAS FULLY SUCCESSFUL. C C IERR = 1 X MAY BE IN ERROR DUE TO THE CALCULATION C OF COND. C C IERR = 2 CND IS .FALSE. WHEN X = 1.0E4. X IS SET = 0.0. C C IERR = 3 CND IS .TRUE. FOR X .GE. XL. X IS SET TO XL. C LOGICAL CND EXTERNAL FUN, COND IERR = 0 C C SEARCH FOR AN INTERVAL (X1, X2) CONTAINING X WHERE C X1 .GE. 0.01269 C X1 = AMAX1(.01269, XL) CALL COND(FUN,X1,CND,NUM,IER) IF (CND) GO TO 20 C X2 = 10.1269 DO 10 I = 1,4 IF (X2 .LE. X1) GO TO 10 CALL COND(FUN,X2,CND,NUM1,IER) NUM = NUM + NUM1 IF (CND) GO TO 200 X1 = X2 10 X2 = 10.0*X2 GO TO 300 C 20 IF (X1 .EQ. XL) GO TO 400 C C SEARCH FOR AN INTERVAL (X1, X2) CONTAINING X WHERE C X2 .LE. 0.01269 C X2 = X1 X1 = -.100358 DO 30 I = 1,6 X1 = AMAX1(X1, XL) CALL COND(FUN,X1,CND,NUM1,IER) NUM = NUM + NUM1 IF(.NOT. CND) GO TO 200 X2 = X1 IF (X1 .EQ. XL) GO TO 400 30 X1 = 10.0*X1 C C SEARCH FOR X IN THE INTERVAL (X1, X2) BY BISECTION C 200 DX = X2 - X1 XBAR = X1 + DX/2.0 CALL COND(FUN,XBAR,CND,NUM1,IERR) NUM = NUM + NUM1 XM = AMAX1(ABS(X1), ABS(X2)) TOL = ETA IF (XM .GT. 1.0) TOL = ETA*XM IF (DX .LE. TOL) GO TO 250 IF(CND) GO TO 225 X1 = XBAR GO TO 200 225 X2 = XBAR GO TO 200 C C FINAL ASSEMBLY C 250 IF(CND) GO TO 275 X = X2 RETURN 275 X = XBAR RETURN C C ERROR RETURN WHEN X COULD NOT BE FOUND IN THE INTERVAL C (-1.0E4, 1.OE4). C 300 X = 0.0 IERR = 2 RETURN 400 X = XL IERR = 3 RETURN END SUBROUTINE ABCON1 (FUN, C, NUM, IERR) C----------------------------------------------------------------------- C C COMPUTATION OF THE ABSCISSA OF CONVERGENCE C OF A FUNCTION WHICH IS NOT TOO OSCILLATORY C C ----------------- C C FUN IS A REAL SUBROUTINE DEFINED BY THE USER. THE ACTUAL NAME C FOR FUN NEEDS TO BE DECLARED EXTERNAL IN THE DRIVER PROGRAM. C FUN HAS THE ARGUMENTS X, Y, A, AND B. C C C IS THE CALCULATED VALUE OF THE ABSCISSA OF CONVERGENCE. C C NUM IS A VARIABLE. ON OUTPUT IT HAS FOR ITS VALUE THE NUMBER C OF EVALUATIONS OF FUN THAT WERE PERFORMED. C C IERR IS AN OUTPUT INTEGER REPORTING THE STATUS OF THE C CALCULATION OF C. IERR IS ASSIGNED VALUES AS FOLLOWS... C C IERR = 0 THE CALCULATION WAS SUCCESSFUL. C C IERR = 1 THE REQUESTED ACCURACY MAY NOT HAVE BEEN C OBTAINED. MORE SUBINTERVALS MAY BE REQUIRED C IN THE NUMERICAL QUADRATURES IN SUBROUTINES C ACOND AND XCOND. C C IERR = 2 C COULD NOT BE CALCULATED WITH SUFFICIENT C ACCURACY, OR AN INTERVAL CONTAINING C COULD C NOT BE FOUND. THE SPECIAL VALUE C = 0.0 IS C ASSIGNED. C C----------------------------------------------------------------------- LOGICAL CMPLEX, IEND, RIGHT EXTERNAL FUN, ACOND, XCOND C ETA = 0.01 CMPLEX = .FALSE. C X1 = .01269 CALL XCOND (FUN,X1,RIGHT,NUM,IERR) IF (.NOT. RIGHT) GO TO 10 CALL ACOND (FUN,X1,RIGHT,NUM1,IERR) NUM = NUM + NUM1 IF (RIGHT) GO TO 30 CMPLEX = .TRUE. C C SEARCH FOR AN INTERVAL (X1, X2) CONTAINING X WHERE C X1 .GE. 0.01269 C 10 X2 = 10.1269 DO 22 I = 1,4 IF (CMPLEX) GO TO 20 CALL XCOND (FUN,X2,RIGHT,NUM1,IERR) NUM = NUM + NUM1 IF (.NOT. RIGHT) GO TO 21 20 CALL ACOND (FUN,X2,RIGHT,NUM1,IERR) NUM = NUM + NUM1 IF (RIGHT) GO TO 50 CMPLEX = .TRUE. 21 X1 = X2 X2 = 10.0*X2 22 CONTINUE GO TO 100 C C SEARCH FOR AN INTERVAL (X1, X2) CONTAINING X WHERE C X2 .LE. 0.01269 C 30 X2 = X1 X1 = -.100358 DO 40 I = 1,6 CALL XCOND (FUN,X1,RIGHT,NUM1,IERR) NUM = NUM + NUM1 IF (.NOT. RIGHT) GO TO 50 CALL ACOND (FUN,X1,RIGHT,NUM1,IERR) NUM = NUM + NUM1 IF (.NOT. RIGHT) GO TO 45 X2 = X1 X1 = 10.0*X1 40 CONTINUE GO TO 100 C 45 CMPLEX = .TRUE. C C SEARCH FOR X IN THE INTERVAL (X1, X2) BY BISECTION C 50 DX = X2 - X1 XBAR = X1 + DX/2.0 XM = AMAX1(ABS(X1), ABS(X2)) TOL = ETA IF (XM .GT. 1.0) TOL = ETA*XM IEND = DX .LE. TOL C IF (CMPLEX) GO TO 60 CALL XCOND (FUN,XBAR,RIGHT,NUM1,IERR) NUM = NUM + NUM1 IF (RIGHT) GO TO 60 IF (IEND) GO TO 80 X1 = XBAR GO TO 50 C 60 CALL ACOND (FUN,XBAR,RIGHT,NUM1,IERR) NUM = NUM + NUM1 IF (RIGHT) GO TO 70 IF (IEND) GO TO 80 X1 = XBAR CMPLEX = .TRUE. GO TO 50 70 X2 = XBAR IF (.NOT. IEND) GO TO 50 C C STANDARD TERMINATION C 80 C = X2 RETURN C C ERROR RETURN WHEN X CANNOT BE FOUND IN (-1.E4, 1.E4) C 100 C = 0.0 IERR = 2 RETURN END SUBROUTINE ACOND (FUN, X, COND, NUM, IERR) C----------------------------------------------------------------------- C C THIS SUBROUTINE TESTS WHETHER OR NOT A GIVEN VALUE OF X C LIES TO THE RIGHT OF THE ABSCISSA OF CONVERGENCE OF THE C COMPLEX FUNCTION DEFINED BY FUN WHEN NO SINGULARITIES LIE C ON THE REAL AXIS. C C ---------------- C C FUN IS A REAL SUBROUTINE DEFINED BY THE USER. THE ACTUAL NAME C FOR FUN NEEDS TO BE DECLARED EXTERNAL IN THE DRIVER PROGRAM. C FUN HAS THE ARGUMENTS X, Y, A, AND B. C C X IS A REAL NUMBER. THE LOGICAL VARIABLE COND = .TRUE. IF C X .GT. C, WHERE C IS THE ABSCISSA OF CONVERGENCE, AND .FALSE. C IF X .LT. C. C C NUM IS A VARIABLE. ON OUTPUT IT HAS FOR ITS VALUE THE NUMBER C OF EVALUATIONS OF FUN THAT WERE PERFORMED. C C IERR IS AN OUTPUT INTEGER INDICATING THE STATUS OF THE C CALCULATION. IT IS ASSIGNED VALUES AS FOLLOWS... C C IERR = 0 THE CALCULATION WAS SUCCESSFUL. C C IERR = 1 THE CALCULATION OF COND MAY NOT BE C ACCURATE FOR ALL VALUES OF X. C C----------------------------------------------------------------------- DIMENSION IWK(100), WK(400) LOGICAL COND EXTERNAL FUN, ACONDF, ACONDG C-------------------------- DATA L /100/, M /400/ DATA AERR /1.E-30/, RERR /1.E-4/, TOL /1.E-4/ C-------------------------- C = X C C CALCULATION OF THE INTEGRAL OF ACONDF FROM X TO INFINITY. C CALL QAGI1 (ACONDF,FUN,Y,C,X,1,AERR,RERR,Z1,ERROR1,NUM1,IER1, * L,M,N,IWK,WK) C C CALCULATION OF THE INTEGRAL OF ACONDG FROM 0 TO INFINITY. C A = 0.0 CALL QAGI1 (ACONDG,FUN,Y,C,A,1,AERR,RERR,Z2,ERROR2,NUM2,IER2, * L,M,N,IWK,WK) NUM = NUM1 + NUM2 IER = MAX0(IER1, IER2) C C DETERMINATION OF COND. C COND = .FALSE. IF (ABS(Z1 - Z2) .LE. TOL*AMAX1(ABS(Z1),ABS(Z2))) COND = .TRUE. C C SET IERR AND RETURN C IERR = 0 IF (IER .GT. 4) IERR = 1 RETURN END FUNCTION ACONDF (X, Y, C, FUN) C----------------------------------------------------------------------- C ACONDF IS THE FUNCTION INTEGRATED ALONG THE X-AXIS IN C ACOND. Y IS A DUMMY VARIABLE. C----------------------------------------------------------------------- EXTERNAL FUN C CALL FUN (X, 0.0, A, B) T = 1.0/((X - C) + 1.0) ACONDF = A*T*T RETURN END FUNCTION ACONDG (X, Y, C, FUN) C----------------------------------------------------------------------- C ACONDG IS THE FUNCTION INTEGRATED ALONG THE LINE X = C C IN ACOND. Y IS A DUMMY VARIABLE. C----------------------------------------------------------------------- EXTERNAL FUN C CALL FUN (C, X, A, B) CALL CREC (1.0, X, S, T) U = S*S - T*T V = 2.0*S*T ACONDG = -(A*V + B*U) RETURN END SUBROUTINE XCOND (FUN, X, COND, NUM, IERR) C----------------------------------------------------------------------- C C THIS SUBROUTINE TESTS WHETHER OR NOT A GIVEN VALUE OF X C LIES TO THE RIGHT OF ALL SINGULARITIES OF THE COMPLEX C FUNCTION DEFINED BY FUN WHICH LIE ON THE REAL AXIS. C C ------------ C C FUN IS A REAL SUBROUTINE DEFINED BY THE USER. THE ACTUAL NAME C FOR FUN NEEDS TO BE DECLARED EXTERNAL IN THE DRIVER PROGRAM. C FUN HAS THE ARGUMENTS X, Y, A, AND B. C C X IS A REAL NUMBER. THE LOGICAL VARIABLE COND = .TRUE IF C X .GT. C, WHERE C IS THE ABSCISSA OF THE SINGULARITY ON THE C REAL AXIS WHICH LIES FARTHEST TO THE RIGHT, AND .FALSE. IF C X .LT. C. C C NUM IS A VARIABLE. ON OUTPUT IT HAS FOR ITS VALUE THE NUMBER C OF EVALUATIONS OF FUN THAT WERE PERFORMED. C C IERR IS AN OUTPUT INTEGER INDICATING THE STATUS OF THE C CALCULATION. IT IS ASSIGNED VALUES AS FOLLOWS... C C IERR = 0 THE CALCULATION WAS SUCCESSFUL. C C IERR = 1 THE CALCULATION OF COND MAY NOT BE C ACCURATE FOR ALL VALUES OF X. C C----------------------------------------------------------------------- DIMENSION IWK(100), WK(400) LOGICAL COND EXTERNAL FUN, XCONDX, XCONDY C-------------------------- DATA L /100/, M /400/ DATA AERR /1.E-30/, RERR /1.E-4/, TOL /1.E-4/ DATA EPSR /1.E-2/ C-------------------------- C = 1.0 - X Y = EPSR COND = .FALSE. C C NUMERICAL INTEGRATION OF THE IMAGINARY PART OF THE INTEGRAND C ALONG THE LINE Y = EPSR. C CALL QAGI1 (XCONDY,FUN,Y,C,X,1,AERR,RERR,Z,ERROR,NUM,IERR, * L,M,N,IWK,WK) IF (IERR .NE. 0) GO TO 100 C C DETERMINATION OF COND. C Y1 = 0.5*Y T = (XCONDX(X,Y,C,FUN) + 4.0*XCONDX(X,Y1,C,FUN) + * XCONDX(X,0.0,C,FUN))*EPSR/6.0 NUM = NUM + 3 IF (T*Z .GT. 0.0) RETURN IF (ABS(T + Z) .GT. TOL*AMAX1(ABS(T), ABS(Z))) RETURN COND = .TRUE. RETURN C C ERROR RETURN C 100 IERR = 1 RETURN END FUNCTION XCONDX (X,Y,C,FUN) C C REAL PART OF THE INTEGRAND IN XCOND C EXTERNAL FUN C CALL FUN (X, Y, A, B) CALL CREC (X + C, Y, S, T) U = S*S - T*T V = 2.0*S*T XCONDX = A*U - B*V RETURN END FUNCTION XCONDY (X,Y,C,FUN) C C IMAGINARY PART OF INTEGRAND IN XCOND C EXTERNAL FUN C CALL FUN (X, Y, A, B) CALL CREC (X + C, Y, S, T) U = S*S - T*T V = 2.0*S*T XCONDY = A*V + B*U RETURN END SUBROUTINE LAINV1(FUN,T,C,EPSRE,EPSAB,RESULT,ESTERR,NUM, * IER) C C ...................................................................... C C 1. LAINV1 C INVERSION OF LAPLACE TRANSFORM USING THE DURBIN FORMULA C IN COMBINATION WITH THE EPSILON ALGORITHM C C 2. PURPOSE C THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO THE C INVERSE LAPLACE TRANSFORM F(T) OF FUN, FOR THE VALUE C OF THE INDEPENDENT VARIABLE EQUAL TO T, HOPEFULLY C SATISFYING THE FOLLOWING CLAIM FOR ACCURACY .... C ABS(F(T)-RESULT).LE.MAX(EPSAB,EPSRE*ABS(F(T))) C C 3. CALLING SEQUENCE C CALL LAINV1(FUN,T,C,EPSRE,EPSAB,RESULT,ESTERR,NUM,IER) C C INPUT PARAMETERS C FUN - REAL C SUBROUTINE DEFINING THE LAPLACE TRANSFORM AS C A COMPLEX FUNCTION. THE CALLING SEQUENCE OF C FUN IS CALL FUN(A,B,C,D) WHERE C A - REAL C REAL PART OF THE INDEPENDENT VARIABLE C OF THE LAPLACE TRANSFORM (INPUT) C B - REAL C IMAGINARY PART OF THE INDEPENDENT C VARIABLE OF THE LAPLACE TRANSFORM (INPUT) C C - REAL C REAL PART OF THE VALUE OF THE LAPLACE C TRANSFORM (OUTPUT) C D - REAL C IMAGINARY PART OF THE VALUE OF THE C LAPLACE TRANSFORM (OUTPUT) C THE ACTUAL NAME FOR FUN NEEDS TO BE DECLARED C EXTERNAL IN THE DRIVER PROGRAM. C C T - REAL C VALUE OF THE INDEPENDENT VARIABLE FOR WHICH THE C INVERSE LAPLACE TRANSFORM HAS TO BE COMPUTED. C T SHOULD BE GREATER THAN ZERO. C C C - REAL C ABSCISSA OF CONVERGENCE OF THE LAPLACE TRANSFORM C C EPSRE - REAL C RELATIVE ACCURACY REQUESTED. IT IS ASSUMED THAT C EPSRE .GE. 0. IF ONE WANTS ACCURACY TO K SIGNIFICANT C FIGURES, THEN RERR SHOULD BE SET = 10.0**(-K). C C EPSAB - REAL C ABSOLUTE ACCURACY REQUESTED. IT IS ASSUMED THAT C EPSAB .GE. 0. THE ROUTINE TRIES TO SATISFY THE C LEAST STRINGENT OF BOTH ACCURACY REQUIREMENTS. C C OUTPUT PARAMETERS C RESULT - REAL C INVERSE LAPLACE TRANSFORM C C ESTERR - REAL C ESTIMATE OF THE ABSOLUTE ERROR ABS(F(T)-RESULT) C C NUM - INTEGER C NUMBER OF EVALUATIONS OF FUN C C IER - INTEGER C PARAMETER GIVING INFORMATION ON THE TERMINATION C OF THE ALGORITHM C IER = 0 NORMAL AND RELIABLE TERMINATION OF THE C ROUTINE C IER = 1 THE COMPUTATIONS ARE TERMINATED BECAUSE C THE BOUND ON THE NUMBER OF EVALUATIONS C OF FUN HAS BEEN ACHIEVED. THIS BOUND C IS EQUAL TO 8*MAX+5 WHERE MAX IS A C NUMBER INITIALIZED IN A DATA C STATEMENT. ONE CAN ALLOW MORE FUNCTION C EVALUATIONS BY INCREASING THE VALUE OF C MAX IN THE DATA-STATEMENT. C IER = 2 THE VALUE OF T IS LESS THAN OR EQUAL C TO ZERO. C C 4. SUBROUTINES OR FUNCTIONS NEEDED C FUN - USER PROVIDED SUBROUTINE C CQEXT - EPSILON ALGORITHM C SPMPAR - THIS FUNCTION IS CALLED BY C CQEXT, AND PROVIDES MACHINE CONSTANTS C ATAN, EXP, AMAX1, SIN, ABS, C DBLE, CMPLX, REAL - FORTRAN FUNCTIONS C C ...................................................................... C COMPLEX REX,CRES,RES3LA INTEGER I,IER,K,KC,KK,KS,M,NEX,NRES,NUM DIMENSION SI(32),RES3LA(3),REX(52) C C THE ARRAY SI CONTAINS VALUES OF THE SINE AND COSINE FUNCTIONS C REQUIRED IN THE DURBIN FORMULA. SI(8) AND SI(16) ARE GIVEN IN C THE FOLLOWING DATA STATEMENT. THE OTHER VALUES ARE COMPUTED. C DATA SI(8),SI(16)/ 1.0E+00,0.0E+00/ C C MAX IS A BOUND ON THE NUMBER OF TERMS USED IN THE DURBIN C FORMULA. C DATA MAX/500/ C .................................................... C C EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE C SMALLEST NUMBER SUCH THAT 1 + EPS .GT. 1. C EPS = SPMPAR(1) C .................................................... C C CALCULATION OF THE RELATIVE TOLERANCE USED. C TOL = 10.0*EPS EPSR1 = AMAX1(TOL,EPSRE) C C TEST ON VALIDITY OF THE INPUT PARAMETER T C IER = 2 RESULT = 0.0E+00 ESTERR = 1.0E+00 NUM = 0 IF (T.LE.0.0E+00) GO TO 999 C C PID16 IS EQUAL TO PI/16 C PID16 = ATAN(1.0E+00)/4.0E+00 C C COMPUTATION OF THE ELEMENTS OF THE ARRAY SI C AK = 1.0E+00 DO 10 K=1,7 SI(K) = SIN(AK*PID16) AK = AK+1.0E+00 KK = 16-K SI(KK) = SI(K) 10 CONTINUE IER = 0 NRES = 0 DO 20 K=17,32 SI(K) = -SI(K-16) 20 CONTINUE C C INITIALIZATION OF THE SUMMATION OF THE DURBIN FORMULA. C ARG = PID16/T ARE = C+2.0E+00/T AIM = 0.0E+00 BB = EXP(ARE*T)/(1.6E+01*T) CALL FUN (ARE,AIM,FRE,FIM) NUM = 5 R = 5.0E-01*FRE S = 0.0 NEX = 0 KC = 8 KS = 0 C C MAIN LOOP FOR THE SUMMATION C DO 40 I=1,MAX M = 8 IF (I.EQ.1) M = 12 DO 30 K=1,M AIM = AIM+ARG KC = KC+1 KS = KS+1 IF (KC.GT.32) KC = 1 IF (KS.GT.32) KS = 1 CALL FUN(ARE,AIM,FRE,FIM) A = FRE*SI(KC) B = -FIM*SI(KS) R = DBLE(R) + DBLE(A) + DBLE(B) E = FRE*SI(KS) F = FIM*SI(KC) S = DBLE(S) + DBLE(E) + DBLE(F) 30 CONTINUE NUM = NUM+8 NEX = NEX+1 REX(NEX) = CMPLX(R, S) C C EXTRAPOLATION USING THE EPSILON ALGORITHM C IF(NEX.GE.3) CALL CQEXT(NEX,REX,CRES,ESTERR,RES3LA,NRES) IF(NRES.LT.4) GO TO 40 C C COMPUTATION OF INTERMEDIATE RESULT AND ESTIMATE OF THE C ABSOLUTE ERROR C RESULT = REAL(CRES) RESULT = RESULT * BB ESTERR = ESTERR * BB IF (ESTERR.LT.AMAX1(EPSAB,EPSR1*ABS(RESULT)).AND.ABS(R*BB- * RESULT).LT.5.0E-01*ABS(RESULT)) GO TO 999 40 CONTINUE C C SET ERROR FLAG IN THE CASE THAT THE NUMBER OF TERMS IN THE C SUMMATION IS EQUAL TO MAX C IER = 1 999 RETURN END SUBROUTINE CQEXT(N,EPSTAB,RESULT,ABSERR,RES3LA,NRES) C C 1. CQEXT C EPSILON ALGORITHM C STANDARD FORTRAN SUBROUTINE C COMPLEX VERSION C C 2. PURPOSE C THE ROUTINE DETERMINES THE LIMIT OF A GIVEN SEQUENCE OF C APPROXIMATIONS, BY MEANS OF THE EPSILON ALGORITHM C OF P. WYNN. C AN ESTIMATE OF THE ABSOLUTE ERROR IS ALSO GIVEN. C THE CONDENSED EPSILON TABLE IS COMPUTED. ONLY THOSE C ELEMENTS NEEDED FOR THE COMPUTATION OF THE NEXT DIAGONAL C ARE PRESERVED. C C 3. CALLING SEQUENCE C CALL CQEXT(N,EPSTAB,RESULT,ABSERR,RES3LA,NRES) C C PARAMETERS C N - INTEGER C EPSTAB(N) CONTAINS THE NEW ELEMENT IN THE C FIRST COLUMN OF THE EPSILON TABLE. C C EPSTAB - COMPLEX C VECTOR OF DIMENSION 52 CONTAINING THE ELEMENTS C OF THE TWO LOWER DIAGONALS OF THE C TRIANGULAR EPSILON TABLE C THE ELEMENTS ARE NUMBERED STARTING AT THE C RIGHT-HAND CORNER OF THE TRIANGLE. C C RESULT - COMPLEX C RESULTING APPROXIMATION TO THE INTEGRAL C C ABSERR - REAL C ESTIMATE OF THE ABSOLUTE ERROR OF THE REAL C PART OF RESULT COMPUTED FROM RESULT AND C THE 3 PREVIOUS RESULTS C C RES3LA - COMPLEX C VECTOR OF DIMENSION 3 CONTAINING THE LAST 3 C RESULTS C C NRES - INTEGER C NUMBER OF CALLS TO THE ROUTINE C (SHOULD BE ZERO AT FIRST CALL) C C 4. SUBROUTINES OR FUNCTIONS NEEDED C - SPMPAR, CDIVID C - FORTRAN ABS, AMAX1, CABS, CMPLX, C REAL, AIMAG, SNGL C C .................................................................. C COMPLEX DELTA1,DELTA2,DELTA3, * EPSTAB,E0,E1,E2,E3, * RES,RESULT,RES3LA,SS DOUBLE PRECISION R,S,U1,U2,U3,V1,V2,V3,SS1,SS2,W1,W2 INTEGER I,IB,IB2,IE,INDX,K1,K2,K3,LIMEXP,N,NEWELM,NRES,NUM DIMENSION EPSTAB(52),RES3LA(3) C C LIST OF MAJOR VARIABLES C ----------------------- C C E0 - THE 4 ELEMENTS ON WHICH THE C E1 COMPUTATION OF A NEW ELEMENT IN C E2 THE EPSILON TABLE IS BASED C E3 E0 C E3 E1 NEW C E2 C NEWELM - NUMBER OF ELEMENTS TO BE COMPUTED IN THE NEW C DIAGONAL C ERROR - ERROR = ABS(E1-E0)+ABS(E2-E1)+ABS(NEW-E2) C RESULT - THE ELEMENT IN THE NEW DIAGONAL WITH LEAST VALUE C OF ERROR C C MACHINE DEPENDENT CONSTANTS C --------------------------- C C EPMACH IS THE LARGEST RELATIVE SPACING. C OFLOW IS THE LARGEST POSITIVE MAGNITUDE. C LIMEXP IS THE MAXIMUM NUMBER OF ELEMENTS THE EPSILON C TABLE CAN CONTAIN. IF THIS NUMBER IS REACHED, THE UPPER C DIAGONAL OF THE EPSILON TABLE IS DELETED. C C***FIRST EXECUTABLE STATEMENT OFLOW = SPMPAR(3) EPMACH = SPMPAR(1) NRES = NRES+1 ABSERR = OFLOW RESULT = EPSTAB(N) IF(N.LT.3) GO TO 100 LIMEXP = 50 EPSTAB(N+2) = EPSTAB(N) NEWELM = (N-1)/2 EPSTAB(N) = CMPLX(OFLOW,0.0) NUM = N K1 = N DO 40 I = 1,NEWELM K2 = K1-1 K3 = K1-2 RES = EPSTAB(K1+2) E0 = EPSTAB(K3) E1 = EPSTAB(K2) E2 = RES E1ABS = CABS(E1) A1 = REAL(E0) A2 = AIMAG(E0) B1 = REAL(E1) B2 = AIMAG(E1) C1 = REAL(E2) C2 = AIMAG(E2) ERR2 = ABS(C1 - B1) ERR3 = ABS(B1 - A1) IF(ABS(A1-B1) .GT. EPMACH*AMAX1(ABS(A1),ABS(B1)) .OR. * ABS(A2-B2) .GT. EPMACH*AMAX1(ABS(A2),ABS(B2))) GO TO 10 IF(ABS(B1-C1) .GT. EPMACH*AMAX1(ABS(B1),ABS(C1)) .OR. * ABS(B2-C2) .GT. EPMACH*AMAX1(ABS(B2),ABS(C2))) GO TO 10 C C IF E0, E1 AND E2 ARE EQUAL TO WITHIN MACHINE C ACCURACY, CONVERGENCE IS ASSUMED. C RESULT = E2 C ABSERR = CABS(E1-E0)+CABS(E2-E1) C RESULT = RES ABSERR = ERR2+ERR3 C***JUMP OUT OF DO-LOOP GO TO 100 10 E3 = EPSTAB(K1) EPSTAB(K1) = E1 D1 = REAL(E3) D2 = AIMAG(E3) ERR1 = ABS(B1 - D1) C C IF TWO ELEMENTS ARE VERY CLOSE TO EACH OTHER, OMIT C A PART OF THE TABLE BY ADJUSTING THE VALUE OF N C DELTA1 = E1 - E3 DELTA2 = E2 - E1 DELTA3 = E1 - E0 IF(CABS(DELTA1) .LE. EPMACH*AMAX1(E1ABS,CABS(E3))) GO TO 20 IF(CABS(DELTA2) .LE. EPMACH*AMAX1(E1ABS,CABS(E2))) GO TO 20 IF(CABS(DELTA3) .LE. EPMACH*AMAX1(CABS(E0),E1ABS)) GO TO 20 R = REAL(DELTA1) S = AIMAG(DELTA1) CALL CDIVID(1.D0,0.D0,R,S,U1,V1) R = REAL(DELTA2) S = AIMAG(DELTA2) CALL CDIVID(1.D0,0.D0,R,S,U2,V2) R = REAL(DELTA3) S = AIMAG(DELTA3) CALL CDIVID(1.D0,0.D0,R,S,U3,V3) SS1 = U1 + U2 - U3 SS2 = V1 + V2 - V3 SS = CMPLX(SNGL(SS1), SNGL(SS2)) EPSINF = CABS(SS*E1) C C TEST TO DETECT IRREGULAR BEHAVIOUR IN THE TABLE, AND C EVENTUALLY OMIT A PART OF THE TABLE ADJUSTING THE VALUE C OF N. C IF(EPSINF.GT.1.0E-04) GO TO 30 20 N = I+I-1 C***JUMP OUT OF DO-LOOP GO TO 50 C C COMPUTE A NEW ELEMENT AND EVENTUALLY ADJUST C THE VALUE OF RESULT. C 30 CALL CDIVID(1.D0,0.D0,SS1,SS2,W1,W2) RES1 = REAL(E1) + SNGL(W1) RES2 = AIMAG(E1) + SNGL(W2) RES = CMPLX(RES1,RES2) EPSTAB(K1) = RES K1 = K1-2 ERROR = ERR2+ABS(C1-REAL(RES))+ERR3 IF(ERROR.GT.ABSERR) GO TO 40 ABSERR = ERROR RESULT = RES 40 CONTINUE C C SHIFT THE TABLE. C 50 IF(N.EQ.LIMEXP) N = 2*(LIMEXP/2)-1 IB = 1 IF((NUM/2)*2.EQ.NUM) IB = 2 IE = NEWELM+1 DO 60 I=1,IE IB2 = IB+2 EPSTAB(IB) = EPSTAB(IB2) IB = IB2 60 CONTINUE IF(NUM.EQ.N) GO TO 80 INDX = NUM-N+1 DO 70 I = 1,N EPSTAB(I)= EPSTAB(INDX) INDX = INDX+1 70 CONTINUE 80 IF(NRES.GE.4) GO TO 90 RES3LA(NRES) = RESULT ABSERR = OFLOW GO TO 100 C C COMPUTE ERROR ESTIMATE C 90 ABSERR = ABS(REAL(RESULT-RES3LA(3)))+ABS(REAL(RESULT-RES3LA(2))) * +ABS(REAL(RESULT-RES3LA(1))) RES3LA(1) = RES3LA(2) RES3LA(2) = RES3LA(3) RES3LA(3) = RESULT 100 ABSERR = AMAX1(ABSERR,5.0E+00*EPMACH*ABS(REAL(RESULT))) RETURN END SUBROUTINE QAGI1(F,PHI,Y,C,BOUND,INF,EPSABS,EPSREL,RESULT,ABSERR, * NEVAL,IER,LIMIT,LENW,LAST,IWORK,WORK) C----------------------------------------------------------------------- C C INTEGRATION OVER INFINITE INTERVALS C C----------------------------------------------------------------------- C C PURPOSE C THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO A GIVEN C INTEGRAL I = INTEGRAL OF F OVER (BOUND,+INFINITY) C OR I = INTEGRAL OF F OVER (-INFINITY,BOUND) C OR I = INTEGRAL OF F OVER (-INFINITY,+INFINITY), C HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY C ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). F HAS THE C ARGUMENTS X AND PHI WHERE PHI IS A FUNCTION. C C PARAMETERS C ON ENTRY C F - REAL C FUNCTION SUBPROGRAM DEFINING THE INTEGRAND C FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE C DECLARED E X T E R N A L IN THE DRIVER PROGRAM. C F HAS THE ARGUMENTS X AND PHI. C C PHI - REAL C FUNCTION SUBPROGRAM HAVING A SINGLE REAL ARGUMENT. C THE ACTUAL NAME FOR PHI MUST BE DECLARED EXTERNAL C IN THE DRIVER PROGRAM. C C BOUND - REAL C FINITE BOUND OF INTEGRATION RANGE C (HAS NO MEANING IF INTERVAL IS DOUBLY-INFINITE) C C Y - REAL C PARAMETER FOR USE IN XCOND. ORDINATE OF C HORIZONTAL LINE ALONG WHICH INTEGRATION C IS PERFORMED. C C C - REAL C PARAMETER FOR USE IN ACOND AND XCOND. C C INF - INTEGER C INDICATING THE KIND OF INTEGRATION RANGE C INVOLVED C INF = 1 CORRESPONDS TO (BOUND,+INFINITY), C INF = -1 TO (-INFINITY,BOUND), C INF = 2 TO (-INFINITY,+INFINITY). C C EPSABS - REAL C ABSOLUTE ACCURACY REQUESTED C C EPSREL - REAL C RELATIVE ACCURACY REQUESTED C C ON RETURN C RESULT - REAL C APPROXIMATION TO THE INTEGRAL C C ABSERR - REAL C ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR, C WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT) C C NEVAL - INTEGER C NUMBER OF INTEGRAND EVALUATIONS C C IER - INTEGER C IER = 0 NORMAL AND RELIABLE TERMINATION OF THE C ROUTINE. IT IS ASSUMED THAT THE REQUESTED C ACCURACY HAS BEEN ACHIEVED. C - IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE. THE C ESTIMATES FOR RESULT AND ERROR ARE LESS C RELIABLE. IT IS ASSUMED THAT THE REQUESTED C ACCURACY HAS NOT BEEN ACHIEVED. C C IER = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED C HAS BEEN ACHIEVED. ONE CAN ALLOW MORE C SUBDIVISIONS BY INCREASING THE VALUE C OF LIMIT (AND TAKING THE ACCORDING C DIMENSION ADJUSTMENTS INTO ACCOUNT). C HOWEVER, IF THIS YIELDS NO IMPROVEMENT C IT IS ADVISED TO ANALYZE THE INTEGRAND C IN ORDER TO DETERMINE THE INTEGRATION C DIFFICULTIES. IF THE POSITION OF A LOCAL C DIFFICULTY CAN BE DETERMINED (E.G. C SINGULARITY, DISCONTINUITY WITHIN THE C INTERVAL) ONE WILL PROBABLY GAIN FROM C SPLITTING UP THE INTERVAL AT THIS POINT C AND CALLING THE INTEGRATOR ON THE C SUBRANGES. IF POSSIBLE, AN APPROPRIATE C SPECIAL-PURPOSE INTEGRATOR SHOULD BE USED, C WHICH IS DESIGNED FOR HANDLING THE TYPE C OF DIFFICULTY INVOLVED. C = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS C DETECTED, WHICH PREVENTS THE REQUESTED C TOLERANCE FROM BEING ACHIEVED. C THE ERROR MAY BE UNDER-ESTIMATED. C = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR OCCURS C AT SOME POINTS OF THE INTEGRATION C INTERVAL. C = 4 THE ALGORITHM DOES NOT CONVERGE. C ROUNDOFF ERROR IS DETECTED IN THE C EXTRAPOLATION TABLE. C IT IS ASSUMED THAT THE REQUESTED TOLERANCE C CANNOT BE ACHIEVED, AND THAT THE RETURNED C RESULT IS THE BEST WHICH CAN BE OBTAINED. C = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR C SLOWLY CONVERGENT. IT MUST BE NOTED THAT C DIVERGENCE CAN OCCUR WITH ANY OTHER VALUE C OF IER. C = 6 THE INPUT IS INVALID BECAUSE EPSABS C OR EPSREL IS NEGATIVE, LIMIT .LT. 1, C OR LENW .LT. 4 * LIMIT. C RESULT, ABSERR, NEVAL, LAST ARE C SET TO ZERO. C C DIMENSIONING PARAMETERS C LIMIT - INTEGER C DIMENSIONING PARAMETER FOR IWORK C LIMIT DETERMINES THE MAXIMUM NUMBER C OF SUBINTERVALS IN THE PARTITION OF THE GIVEN C INTEGRATION INTERVAL (A,B), LIMIT.GE.1. C IF LIMIT.LT.1, THE ROUTINE WILL END WITH C IER = 6. C C LENW - INTEGER C DIMENSIONING PARAMETER FOR WORK C LENW MUST BE AT LEAST LIMIT*4. C IF LENW.LT.LIMIT*4, THE ROUTINE WILL END C WITH IER = 6. C C LAST - INTEGER C ON RETURN, LAST EQUALS THE NUMBER OF C SUBINTERVALS PRODUCED IN THE SUBDIVISION C PROCESS, WHICH DETERMINES THE NUMBER OF SIGNIFICANT C ELEMENTS ACTUALLY IN THE WORK ARRAYS. C C WORK ARRAYS C IWORK - INTEGER C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST C K ELEMENTS OF WHICH CONTAIN POINTERS C TO THE ERROR ESTIMATES OVER THE SUBINTERVALS, C SUCH THAT WORK(LIMIT*3+IWORK(1)),... , C WORK(LIMIT*3+IWORK(K)) FORM A DECREASING C SEQUENCE, WITH K = LAST IF LAST.LE.(LIMIT/2+2), AND C K = LIMIT+1-LAST OTHERWISE C C WORK - REAL C VECTOR OF DIMENSION AT LEAST LENW C ON RETURN C WORK(1), ..., WORK(LAST) CONTAIN THE LEFT C END POINTS OF THE SUBINTERVALS IN THE C PARTITION OF (A,B), C WORK(LIMIT+1), ..., WORK(LIMIT+LAST) CONTAIN C THE RIGHT END POINTS, C WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) C CONTAIN THE INTEGRAL APPROXIMATIONS OVER C THE SUBINTERVALS, C WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST) C CONTAIN THE ERROR ESTIMATES. C C SUBROUTINES OR FUNCTIONS NEEDED C - QAGIE1 C - QK15I1 C - QPSRT C - QELG C - F (USER PROVIDED FUNCTION) C - PHI (USER PROVIDED FUNCTION) C - SPMPAR C C----------------------------------------------------------------------- REAL WORK(LENW) INTEGER IWORK(LIMIT) EXTERNAL F, PHI C C CHECK VALIDITY OF LIMIT AND LENW. C IER = 6 NEVAL = 0 LAST = 0 RESULT = 0.0 ABSERR = 0.0 IF (LIMIT .LT. 1 .OR. LENW .LT. LIMIT*4) RETURN C C PREPARE CALL FOR QAGIE1. C L1 = LIMIT + 1 L2 = LIMIT + L1 L3 = LIMIT + L2 C CALL QAGIE1(F,PHI,Y,C,BOUND,INF,EPSABS,EPSREL,LIMIT,RESULT,ABSERR, * NEVAL,IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST) RETURN END SUBROUTINE QAGIE1(F,PHI,Y,C,BOUND,INF,EPSABS,EPSREL,LIMIT,RESULT, * ABSERR,NEVAL,IER,ALIST,BLIST,RLIST,ELIST,IORD,LAST) C----------------------------------------------------------------------- C C INTEGRATION OVER INFINITE INTERVALS C C----------------------------------------------------------------------- C C PURPOSE C THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO A GIVEN C INTEGRAL I = INTEGRAL OF F OVER (BOUND,+INFINITY) C OR I = INTEGRAL OF F OVER (-INFINITY,BOUND) C OR I = INTEGRAL OF F OVER (-INFINITY,+INFINITY), C HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY C ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). C C PARAMETERS C ON ENTRY C F - REAL C FUNCTION SUBPROGRAM DEFINING THE INTEGRAND C FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE C DECLARED E X T E R N A L IN THE DRIVER PROGRAM. C F HAS THE ARGUMENTS X AND PHI. C C PHI - REAL C FUNCTION SUBPROGRAM HAVING A SINGLE REAL ARGUMENT. C THE ACTUAL NAME FOR PHI MUST BE DECLARED EXTERNAL C IN THE DRIVER PROGRAM. C C BOUND - REAL C FINITE BOUND OF INTEGRATION RANGE C (HAS NO MEANING IF INTERVAL IS DOUBLY-INFINITE) C C Y - REAL C PARAMETER FOR USE IN XCOND. ORDINATE OF C HORIZONTAL LINE ALONG WHICH INTEGRATION C IS PERFORMED. C C C - REAL C PARAMETER FOR USE IN ACOND AND XCOND. C C INF - INTEGER C INDICATING THE KIND OF INTEGRATION RANGE C INVOLVED C INF = 1 CORRESPONDS TO (BOUND,+INFINITY), C INF = -1 TO (-INFINITY,BOUND), C INF = 2 TO (-INFINITY,+INFINITY). C C EPSABS - REAL C ABSOLUTE ACCURACY REQUESTED C C EPSREL - REAL C RELATIVE ACCURACY REQUESTED C C LIMIT - INTEGER C GIVES AN UPPER BOUND ON THE NUMBER OF C SUBINTERVALS IN THE PARTITION OF (A,B), C LIMIT.GE.1 C C ON RETURN C RESULT - REAL C APPROXIMATION TO THE INTEGRAL C C ABSERR - REAL C ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR, C WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT) C C NEVAL - INTEGER C NUMBER OF INTEGRAND EVALUATIONS C C IER - INTEGER C IER = 0 NORMAL AND RELIABLE TERMINATION OF THE C ROUTINE. IT IS ASSUMED THAT THE REQUESTED C ACCURACY HAS BEEN ACHIEVED. C - IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE. THE C ESTIMATES FOR RESULT AND ERROR ARE LESS C RELIABLE. IT IS ASSUMED THAT THE REQUESTED C ACCURACY HAS NOT BEEN ACHIEVED. C C IER = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED C HAS BEEN ACHIEVED. ONE CAN ALLOW MORE C SUBDIVISIONS BY INCREASING THE VALUE C OF LIMIT (AND TAKING THE ACCORDING C DIMENSION ADJUSTMENTS INTO ACCOUNT). C HOWEVER, IF THIS YIELDS NO IMPROVEMENT C IT IS ADVISED TO ANALYZE THE INTEGRAND C IN ORDER TO DETERMINE THE INTEGRATION C DIFFICULTIES. IF THE POSITION OF A LOCAL C DIFFICULTY CAN BE DETERMINED (E.G. C SINGULARITY, DISCONTINUITY WITHIN THE C INTERVAL) ONE WILL PROBABLY GAIN FROM C SPLITTING UP THE INTERVAL AT THIS POINT C AND CALLING THE INTEGRATOR ON THE C SUBRANGES. IF POSSIBLE, AN APPROPRIATE C SPECIAL-PURPOSE INTEGRATOR SHOULD BE USED, C WHICH IS DESIGNED FOR HANDLING THE TYPE C OF DIFFICULTY INVOLVED. C = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS C DETECTED, WHICH PREVENTS THE REQUESTED C TOLERANCE FROM BEING ACHIEVED. C THE ERROR MAY BE UNDER-ESTIMATED. C = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR OCCURS C AT SOME POINTS OF THE INTEGRATION C INTERVAL. C = 4 THE ALGORITHM DOES NOT CONVERGE. C ROUNDOFF ERROR IS DETECTED IN THE C EXTRAPOLATION TABLE. C IT IS ASSUMED THAT THE REQUESTED TOLERANCE C CANNOT BE ACHIEVED, AND THAT THE RETURNED C RESULT IS THE BEST WHICH CAN BE OBTAINED. C = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR C SLOWLY CONVERGENT. IT MUST BE NOTED THAT C DIVERGENCE CAN OCCUR WITH ANY OTHER VALUE C OF IER. C = 6 THE INPUT IS INVALID BECAUSE EPSABS C OR EPSREL IS NEGATIVE. C RESULT, ABSERR, NEVAL, LAST, RLIST(1), C ELIST(1) AND IORD(1) ARE SET TO ZERO. C ALIST(1) AND BLIST(1) ARE SET TO 0 C AND 1 RESPECTIVELY. C C ALIST - REAL C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST C LAST ELEMENTS OF WHICH ARE THE LEFT C END POINTS OF THE SUBINTERVALS IN THE PARTITION C OF THE TRANSFORMED INTEGRATION RANGE (0,1). C C BLIST - REAL C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST C LAST ELEMENTS OF WHICH ARE THE RIGHT C END POINTS OF THE SUBINTERVALS IN THE PARTITION C OF THE TRANSFORMED INTEGRATION RANGE (0,1). C C RLIST - REAL C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST C LAST ELEMENTS OF WHICH ARE THE INTEGRAL C APPROXIMATIONS ON THE SUBINTERVALS C C ELIST - REAL C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST C LAST ELEMENTS OF WHICH ARE THE MODULI C OF THE ABSOLUTE ERROR ESTIMATES ON THE C SUBINTERVALS C C IORD - INTEGER C VECTOR OF DIMENSION LIMIT, THE FIRST K C ELEMENTS OF WHICH ARE POINTERS TO THE C ERROR ESTIMATES OVER THE SUBINTERVALS, C SUCH THAT ELIST(IORD(1)), ..., ELIST(IORD(K)) C FORM A DECREASING SEQUENCE, WITH K = LAST C IF LAST.LE.(LIMIT/2+2), AND K = LIMIT+1-LAST C OTHERWISE C C LAST - INTEGER C NUMBER OF SUBINTERVALS ACTUALLY PRODUCED C IN THE SUBDIVISION PROCESS C C SUBROUTINES OR FUNCTIONS NEEDED C - QK15I1 C - QPSRT C - QELG C - F (USER-PROVIDED FUNCTION) C - PHI (USER-PROVIDED FUNCTION) C - SPMPAR C C----------------------------------------------------------------------- LOGICAL EXTRAP,NOEXT C DIMENSION ALIST(LIMIT),BLIST(LIMIT),ELIST(LIMIT),IORD(LIMIT), * RES3LA(3),RLIST(LIMIT),RLIST2(52) C EXTERNAL F, PHI C C THE DIMENSION OF RLIST2 IS DETERMINED BY THE VALUE OF C LIMEXP IN SUBROUTINE QELG. C C C LIST OF MAJOR VARIABLES C ----------------------- C C ALIST - LIST OF LEFT END POINTS OF ALL SUBINTERVALS C CONSIDERED UP TO NOW C BLIST - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS C CONSIDERED UP TO NOW C RLIST(I) - APPROXIMATION TO THE INTEGRAL OVER C (ALIST(I),BLIST(I)) C RLIST2 - ARRAY OF DIMENSION AT LEAST (LIMEXP+2), C CONTAINING THE PART OF THE EPSILON TABLE C WICH IS STILL NEEDED FOR FURTHER COMPUTATIONS C ELIST(I) - ERROR ESTIMATE APPLYING TO RLIST(I) C MAXERR - POINTER TO THE INTERVAL WITH LARGEST ERROR C ESTIMATE C ERRMAX - ELIST(MAXERR) C ERLAST - ERROR ON THE INTERVAL CURRENTLY SUBDIVIDED C (BEFORE THAT SUBDIVISION HAS TAKEN PLACE) C AREA - SUM OF THE INTEGRALS OVER THE SUBINTERVALS C ERRSUM - SUM OF THE ERRORS OVER THE SUBINTERVALS C ERRBND - REQUESTED ACCURACY MAX(EPSABS,EPSREL* C ABS(RESULT)) C *****1 - VARIABLE FOR THE LEFT SUBINTERVAL C *****2 - VARIABLE FOR THE RIGHT SUBINTERVAL C LAST - INDEX FOR SUBDIVISION C NRES - NUMBER OF CALLS TO THE EXTRAPOLATION ROUTINE C NUMRL2 - NUMBER OF ELEMENTS CURRENTLY IN RLIST2. IF AN C APPROPRIATE APPROXIMATION TO THE COMPOUNDED C INTEGRAL HAS BEEN OBTAINED, IT IS PUT IN C RLIST2(NUMRL2) AFTER NUMRL2 HAS BEEN INCREASED C BY ONE. C SMALL - LENGTH OF THE SMALLEST INTERVAL CONSIDERED UP C TO NOW, MULTIPLIED BY 1.5 C ERLARG - SUM OF THE ERRORS OVER THE INTERVALS LARGER C THAN THE SMALLEST INTERVAL CONSIDERED UP TO NOW C EXTRAP - LOGICAL VARIABLE DENOTING THAT THE ROUTINE C IS ATTEMPTING TO PERFORM EXTRAPOLATION. I.E. C BEFORE SUBDIVIDING THE SMALLEST INTERVAL WE C TRY TO DECREASE THE VALUE OF ERLARG. C NOEXT - LOGICAL VARIABLE DENOTING THAT EXTRAPOLATION C IS NO LONGER ALLOWED (TRUE-VALUE) C C MACHINE DEPENDENT CONSTANTS C --------------------------- C C EPMACH IS THE LARGEST RELATIVE SPACING. C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. C OFLOW IS THE LARGEST POSITIVE MAGNITUDE. C EPMACH = SPMPAR(1) UFLOW = SPMPAR(2) OFLOW = SPMPAR(3) C C TEST ON VALIDITY OF PARAMETERS C ----------------------------- C NEVAL = 0 LAST = 0 RESULT = 0.0 ABSERR = 0.0 ALIST(1) = 0.0 BLIST(1) = 1.0 RLIST(1) = 0.0 ELIST(1) = 0.0 IORD(1) = 0 IER = 6 IF (EPSABS .LT. 0.0 .OR. EPSREL .LT. 0.0) GO TO 999 IER = 0 RERR = AMAX1(EPSREL, 50.0*EPMACH, 0.5E-14) C C FIRST APPROXIMATION TO THE INTEGRAL C ----------------------------------- C C DETERMINE THE INTERVAL TO BE MAPPED ONTO (0,1). C IF INF = 2 THE INTEGRAL IS COMPUTED AS I = I1+I2, WHERE C I1 = INTEGRAL OF F OVER (-INFINITY,0), C I2 = INTEGRAL OF F OVER (0,+INFINITY). C BOUN = BOUND IF (INF .EQ. 2) BOUN = 0.0 CALL QK15I1 (F, PHI, Y, C, BOUN, INF, 0.0, 1.0, RESULT, ABSERR, * DEFABS, RESABS, EPMACH, UFLOW) C C TEST ON ACCURACY C LAST = 1 RLIST(1) = RESULT ELIST(1) = ABSERR IORD(1) = 1 DRES = ABS(RESULT) ERRBND = AMAX1(EPSABS,RERR*DRES) IF (ABSERR .LE. 100.0*EPMACH*DEFABS .AND. ABSERR .GT. ERRBND) * IER = 2 IF (LIMIT .EQ. 1) IER = 1 IF (IER .NE. 0 .OR. (ABSERR .LE. ERRBND .AND. ABSERR .NE. RESABS) * .OR. ABSERR .EQ. 0.0) GO TO 130 C C INITIALIZATION C -------------- C RLIST2(1) = RESULT ERRMAX = ABSERR MAXERR = 1 AREA = RESULT ERRSUM = ABSERR ABSERR = OFLOW CORREC = 0.0 NRMAX = 1 NRES = 0 KTMIN = 0 NUMRL2 = 2 EXTRAP = .FALSE. NOEXT = .FALSE. IERRO = 0 IROFF1 = 0 IROFF2 = 0 IROFF3 = 0 KSGN = -1 IF (DRES .GE. (1.0 - 50.0*EPMACH)*DEFABS) KSGN = 1 T = 1.0 + 100.0*EPMACH C C MAIN DO-LOOP C ------------ C DO 90 LAST = 2,LIMIT C C BISECT THE SUBINTERVAL WITH NRMAX-TH LARGEST C ERROR ESTIMATE. C A1 = ALIST(MAXERR) B1 = 0.5*(ALIST(MAXERR) + BLIST(MAXERR)) A2 = B1 B2 = BLIST(MAXERR) ERLAST = ERRMAX CALL QK15I1 (F, PHI, Y, C, BOUN, INF, A1, B1, AREA1, ERROR1, * RESABS, DEFAB1, EPMACH, UFLOW) CALL QK15I1 (F, PHI, Y, C, BOUN, INF, A2, B2, AREA2, ERROR2, * RESABS, DEFAB2, EPMACH, UFLOW) C C IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL C AND ERROR AND TEST FOR ACCURACY. C AREA12 = AREA1 + AREA2 ERRO12 = ERROR1 + ERROR2 ERRSUM = ERRSUM + ERRO12 - ERRMAX AREA = AREA + AREA12 - RLIST(MAXERR) IF (DEFAB1 .EQ. ERROR1 .OR. DEFAB2 .EQ. ERROR2) GO TO 15 IF (ABS(RLIST(MAXERR) - AREA12) .GT. 0.1E-04*ABS(AREA12) * .OR. ERRO12 .LT. 0.99*ERRMAX) GO TO 10 IF (EXTRAP) IROFF2 = IROFF2 + 1 IF (.NOT.EXTRAP) IROFF1 = IROFF1 + 1 10 IF (LAST .GT. 10 .AND. ERRO12 .GT. ERRMAX) IROFF3 = IROFF3 + 1 15 RLIST(MAXERR) = AREA1 RLIST(LAST) = AREA2 ERRBND = AMAX1(EPSABS,RERR*ABS(AREA)) C C TEST FOR ROUNDOFF ERROR AND EVENTUALLY C SET ERROR FLAG. C IF (IROFF1 + IROFF2 .GE. 10 .OR. IROFF3 .GE. 20) IER = 2 IF (IROFF2 .GE. 5) IERRO = 3 C C SET ERROR FLAG IN THE CASE THAT THE NUMBER OF C SUBINTERVALS EQUALS LIMIT. C IF (LAST .EQ. LIMIT) IER = 1 C C SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR C AT SOME POINTS OF THE INTEGRATION RANGE. C IF (AMAX1(ABS(A1),ABS(B2)) .LE. * T*(ABS(A2) + 0.1E+04*UFLOW)) IER = 4 C C APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. C IF (ERROR2 .GT. ERROR1) GO TO 20 ALIST(LAST) = A2 BLIST(MAXERR) = B1 BLIST(LAST) = B2 ELIST(MAXERR) = ERROR1 ELIST(LAST) = ERROR2 GO TO 30 20 ALIST(MAXERR) = A2 ALIST(LAST) = A1 BLIST(LAST) = B1 RLIST(MAXERR) = AREA2 RLIST(LAST) = AREA1 ELIST(MAXERR) = ERROR2 ELIST(LAST) = ERROR1 C C CALL SUBROUTINE QPSRT TO MAINTAIN THE DESCENDING ORDERING C IN THE LIST OF ERROR ESTIMATES AND SELECT THE C SUBINTERVAL WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE C BISECTED NEXT). C 30 CALL QPSRT (LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX) IF(ERRSUM.LE.ERRBND) GO TO 115 IF(IER.NE.0) GO TO 100 IF(LAST.EQ.2) GO TO 80 IF(NOEXT) GO TO 90 ERLARG = ERLARG-ERLAST IF(ABS(B1-A1).GT.SMALL) ERLARG = ERLARG+ERRO12 IF(EXTRAP) GO TO 40 C C TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE C SMALLEST INTERVAL. C IF(ABS(BLIST(MAXERR)-ALIST(MAXERR)).GT.SMALL) GO TO 90 EXTRAP = .TRUE. NRMAX = 2 40 IF(IERRO.EQ.3.OR.ERLARG.LE.ERTEST) GO TO 60 C C THE SMALLEST INTERVAL HAS THE LARGEST ERROR. C BEFORE BISECTING DECREASE THE SUM OF THE ERRORS C OVER THE LARGER INTERVALS (ERLARG) AND PERFORM C EXTRAPOLATION. C ID = NRMAX JUPBND = LAST IF(LAST.GT.(2+LIMIT/2)) JUPBND = LIMIT+3-LAST DO 50 K = ID,JUPBND MAXERR = IORD(NRMAX) ERRMAX = ELIST(MAXERR) IF(ABS(BLIST(MAXERR)-ALIST(MAXERR)).GT.SMALL) GO TO 90 NRMAX = NRMAX+1 50 CONTINUE C C PERFORM EXTRAPOLATION. C 60 NUMRL2 = NUMRL2+1 RLIST2(NUMRL2) = AREA CALL QELG (NUMRL2, RLIST2, RESEPS, ABSEPS, RES3LA, NRES, * EPMACH, OFLOW) KTMIN = KTMIN+1 IF(KTMIN.GT.5.AND.ABSERR.LT.0.1E-02*ERRSUM) IER = 5 IF(ABSEPS.GE.ABSERR) GO TO 70 KTMIN = 0 ABSERR = ABSEPS RESULT = RESEPS CORREC = ERLARG ERTEST = AMAX1(EPSABS,RERR*ABS(RESEPS)) IF(ABSERR.LE.ERTEST) GO TO 100 C C PREPARE BISECTION OF THE SMALLEST INTERVAL. C 70 IF(NUMRL2.EQ.1) NOEXT = .TRUE. IF(IER.EQ.5) GO TO 100 MAXERR = IORD(1) ERRMAX = ELIST(MAXERR) NRMAX = 1 EXTRAP = .FALSE. SMALL = SMALL*0.5E+00 ERLARG = ERRSUM GO TO 90 80 SMALL = 0.375E+00 ERLARG = ERRSUM ERTEST = ERRBND RLIST2(2) = AREA 90 CONTINUE C C SET FINAL RESULT AND ERROR ESTIMATE. C ------------------------------------ C 100 IF (ABSERR .EQ. OFLOW) GO TO 115 IF (IER + IERRO .EQ. 0) GO TO 110 IF (IERRO .EQ. 3) ABSERR = ABSERR + CORREC IF (IER .EQ. 0) IER = 3 IF (RESULT .NE. 0.0 .AND. AREA .NE. 0.0) GO TO 105 IF (ABSERR .GT. ERRSUM) GO TO 115 IF (AREA .EQ. 0.0) GO TO 130 GO TO 110 105 IF (ABSERR/ABS(RESULT) .GT. ERRSUM/ABS(AREA)) GO TO 115 C C TEST ON DIVERGENCE C 110 IF (KSGN .EQ. -1 .AND. AMAX1(ABS(RESULT),ABS(AREA)) .LE. * DEFABS*0.1E-01) GO TO 130 IF (0.1E-01 .GT. (RESULT/AREA) .OR. (RESULT/AREA) .GT. 0.1E+03 * .OR. ERRSUM .GT. ABS(AREA)) IER = 6 GO TO 130 C C COMPUTE GLOBAL INTEGRAL SUM. C 115 RESULT = 0.0 DO 120 K = 1,LAST RESULT = RESULT + RLIST(K) 120 CONTINUE ABSERR = ERRSUM 130 NEVAL = 30*LAST - 15 IF (INF .EQ. 2) NEVAL = 2*NEVAL IF (IER .GT. 2) IER = IER - 1 999 RETURN END SUBROUTINE QK15I1 (F, PHI, Y, C, BOUN, INF, A, B, RESULT, ABSERR, * RESABS, RESASC, EPMACH, UFLOW) C----------------------------------------------------------------------- C C 1. PURPOSE C THE ORIGINAL (INFINITE) INTEGRATION RANGE IS MAPPED C ONTO THE INTERVAL (0,1) AND (A,B) IS A PART OF (0,1). C IT IS THE PURPOSE TO COMPUTE C I = INTEGRAL OF TRANSFORMED INTEGRAND OVER (A,B), C J = INTEGRAL OF ABS(TRANSFORMED INTEGRAND) OVER (A,B). C C 2. PARAMETERS C ON ENTRY C F - REAL C FUNCTION SUBPROGRAM DEFINING THE INTEGRAND C FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS C TO BE DECLARED E X T E R N A L IN THE C CALLING PROGRAM. F HAS THE ARGUMENTS X AND C PHI. C C PHI - REAL C FUNCTION SUBPROGRAM HAVING A SINGLE REAL C ARGUMENT. THE ACTUAL NAME FOR PHI MUST BE C DECHARED EXTERNAL IN THE DRIVER PROGRAM. C C BOUN - REAL C FINITE BOUND OF ORIGINAL INTEGRATION C RANGE (SET TO ZERO IF INF = +2) C C INF - INTEGER C IF INF = -1, THE ORIGINAL INTERVAL IS C (-INFINITY,BOUND), C IF INF = +1, THE ORIGINAL INTERVAL IS C (BOUND,+INFINITY), C IF INF = +2, THE ORIGINAL INTERVAL IS C (-INFINITY,+INFINITY) AND C THE INTEGRAL IS COMPUTED AS THE SUM OF TWO C INTEGRALS, ONE OVER (-INFINITY,0) C AND ONE OVER (0,+INFINITY). C C A - REAL C LOWER LIMIT FOR INTEGRATION OVER SUBRANGE C OF (0,1) C C B - REAL C UPPER LIMIT FOR INTEGRATION OVER SUBRANGE C OF (0,1) C C EPMACH - REAL C THE RELATIVE PRECISION OF THE FLOATING C ARITHMETIC BEING USED. C C UFLOW - REAL C THE SMALLEST POSITIVE MAGNITUDE. C C ON RETURN C RESULT - REAL C APPROXIMATION TO THE INTEGRAL I C RESULT IS COMPUTED BY APPLYING THE 15-POINT C KRONROD RULE(RESK) OBTAINED BY OPTIMAL C ADDITION OF ABSCISSAE TO THE 7-POINT GAUSS C RULE(RESG). C C ABSERR - REAL C ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR, C WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT) C C RESABS - REAL C APPROXIMATION TO THE INTEGRAL J C C RESASC - REAL C APPROXIMATION TO THE INTEGRAL OF C ABS((TRANSFORMED INTEGRAND)-I/(B-A)) C OVER (A,B) C C 3. SUBROUTINES OR FUNCTIONS NEEDED C - F (USER-PROVIDED FUNCTION) C - PHI (USER-PROVIDED FUNCTION) C C----------------------------------------------------------------------- REAL FV1(7), FV2(7), XGK(8), WGK(8), WG(8) C EXTERNAL F, PHI C C THE ABSCISSAE AND WEIGHTS ARE SUPPLIED FOR THE INTERVAL C (-1,1). BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND C THEIR CORRESPONDING WEIGHTS ARE GIVEN. C C XGK - ABSCISSAE OF THE 15-POINT KRONROD RULE C XGK(2), XGK(4), ... ABSCISSAE OF THE 7-POINT C GAUSS RULE C XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY C ADDED TO THE 7-POINT GAUSS RULE C C WGK - WEIGHTS OF THE 15-POINT KRONROD RULE C C WG - WEIGHTS OF THE 7-POINT GAUSS RULE, CORRESPONDING C TO THE ABSCISSAE XGK(2), XGK(4), ... C WG(1), WG(3), ... ARE SET TO ZERO. C DATA XGK(1),XGK(2),XGK(3),XGK(4),XGK(5),XGK(6),XGK(7), * XGK(8)/ * 0.9914553711208126E+00, 0.9491079123427585E+00, * 0.8648644233597691E+00, 0.7415311855993944E+00, * 0.5860872354676911E+00, 0.4058451513773972E+00, * 0.2077849550078985E+00, 0.0000000000000000E+00/ C DATA WGK(1),WGK(2),WGK(3),WGK(4),WGK(5),WGK(6),WGK(7), * WGK(8)/ * 0.2293532201052922E-01, 0.6309209262997855E-01, * 0.1047900103222502E+00, 0.1406532597155259E+00, * 0.1690047266392679E+00, 0.1903505780647854E+00, * 0.2044329400752989E+00, 0.2094821410847278E+00/ C DATA WG(1),WG(2),WG(3),WG(4),WG(5),WG(6),WG(7),WG(8)/ * 0.0000000000000000E+00, 0.1294849661688697E+00, * 0.0000000000000000E+00, 0.2797053914892767E+00, * 0.0000000000000000E+00, 0.3818300505051189E+00, * 0.0000000000000000E+00, 0.4179591836734694E+00/ C C C LIST OF MAJOR VARIABLES C ----------------------- C C CENTR - MID POINT OF THE INTERVAL C HLGTH - HALF-LENGTH OF THE INTERVAL C ABSC* - ABSCISSA C TABSC* - TRANSFORMED ABSCISSA C FVAL* - FUNCTION VALUE C RESG - RESULT OF THE 7-POINT GAUSS FORMULA C RESK - RESULT OF THE 15-POINT KRONROD FORMULA C RESKH - APPROXIMATION TO THE MEAN VALUE OF THE TRANSFORMED C INTEGRAND OVER (A,B), I.E. TO I/(B-A) C C DINF = MIN0(1,INF) C CENTR = 0.5*(A + B) HLGTH = 0.5*(B - A) TABSC1 = BOUN + DINF*(1.0 - CENTR)/CENTR FVAL1 = F(TABSC1,Y,C,PHI) IF (INF .EQ. 2) FVAL1 = FVAL1 + F(-TABSC1,Y,C,PHI) FC = (FVAL1/CENTR)/CENTR C C COMPUTE THE 15-POINT KRONROD APPROXIMATION TO C THE INTEGRAL, AND ESTIMATE THE ERROR. C RESG = WG(8)*FC RESK = WGK(8)*FC RESABS = ABS(RESK) DO 10 J = 1,7 ABSC = HLGTH*XGK(J) ABSC1 = CENTR - ABSC ABSC2 = CENTR + ABSC TABSC1 = BOUN + DINF*(1.0 - ABSC1)/ABSC1 TABSC2 = BOUN + DINF*(1.0 - ABSC2)/ABSC2 FVAL1 = F(TABSC1,Y,C,PHI) FVAL2 = F(TABSC2,Y,C,PHI) IF (INF .EQ. 2) FVAL1 = FVAL1 + F(-TABSC1,Y,C,PHI) IF (INF .EQ. 2) FVAL2 = FVAL2 + F(-TABSC2,Y,C,PHI) FVAL1 = (FVAL1/ABSC1)/ABSC1 FVAL2 = (FVAL2/ABSC2)/ABSC2 FV1(J) = FVAL1 FV2(J) = FVAL2 FSUM = FVAL1 + FVAL2 RESG = RESG + WG(J)*FSUM RESK = RESK + WGK(J)*FSUM RESABS = RESABS + WGK(J)*(ABS(FVAL1) + ABS(FVAL2)) 10 CONTINUE RESKH = RESK*0.5 RESASC = WGK(8)*ABS(FC - RESKH) DO 20 J = 1,7 RESASC = RESASC + WGK(J)*(ABS(FV1(J)-RESKH) + * ABS(FV2(J)-RESKH)) 20 CONTINUE RESULT = RESK*HLGTH RESASC = RESASC*HLGTH RESABS = RESABS*HLGTH ABSERR = ABS((RESK - RESG)*HLGTH) IF (RESASC .NE. 0.0 .AND. ABSERR .NE. 0.0) ABSERR = RESASC* * AMIN1(1.0, (0.2E+03*ABSERR/RESASC)**1.5) TOL = 50.0*EPMACH IF (RESABS .GT. UFLOW/TOL) ABSERR = AMAX1(ABSERR, TOL*RESABS) RETURN END SUBROUTINE FFT (C,N,ISN,IERR) REAL C(*) C----------------------------------------------------------------------- C THE COMPLEX ARRAY C OF DIMENSION N IS INTERPRETED BY THE CODE C AS A REAL ARRAY OF DIMENSION 2*N. IF THIS ASSOCIATION IS NOT C PERMITTED BY THE FORTRAN BEING USED, THEN THE USER MAY USE THE C SUBROUTINE FFT1. C----------------------------------------------------------------------- IF (IABS(ISN) .NE. 1) GO TO 10 CALL SFFT (C(1),C(2),N,N,N,ISN+ISN,IERR) RETURN 10 IERR = 4 RETURN END SUBROUTINE FFT1 (A,B,N,ISN,IERR) REAL A(N), B(N) C ------------ IF (IABS(ISN) .NE. 1) GO TO 10 CALL SFFT (A,B,N,N,N,ISN,IERR) RETURN 10 IERR = 4 RETURN END SUBROUTINE MFFT (C,N,NDIM,ISN,IERR) REAL C(*) INTEGER N(NDIM) C----------------------------------------------------------------------- C LET NTOT DENOTE THE PRODUCT OF N(1),...,N(NDIM). THE COMPLEX C ARRAY C OF DIMENSION NTOT IS INTERPRETED BY THE ROUTINE AS C A REAL ARRAY OF DIMENSION 2*NTOT. IF THIS ASSOCIATION IS NOT C PERMITTED BY THE FORTRAN BEING USED, THEN THE USER MAY USE C THE SUBROUTINE MFFT1. C----------------------------------------------------------------------- IF (IABS(ISN) .NE. 1) GO TO 40 IF (NDIM .LE. 0) GO TO 50 NTOT = 1 DO 10 I = 1,NDIM NTOT = N(I)*NTOT 10 CONTINUE IF (NTOT .LT. 1) GO TO 30 C ISIGN = ISN + ISN NSPAN = 1 DO 20 I = 1,NDIM NSPAN = N(I)*NSPAN CALL SFFT (C(1),C(2),NTOT,N(I),NSPAN,ISIGN,IERR) IF (IERR .NE. 0) RETURN 20 CONTINUE RETURN C 30 IERR = 1 RETURN 40 IERR = 4 RETURN 50 IERR = 5 RETURN END SUBROUTINE MFFT1 (A,B,N,NDIM,ISN,IERR) REAL A(*), B(*) INTEGER N(NDIM) C ------------ IF (IABS(ISN) .NE. 1) GO TO 40 IF (NDIM .LE. 0) GO TO 50 NTOT = 1 DO 10 I = 1,NDIM NTOT = N(I)*NTOT 10 CONTINUE IF (NTOT .LT. 1) GO TO 30 C NSPAN = 1 DO 20 I = 1,NDIM NSPAN = N(I)*NSPAN CALL SFFT (A,B,NTOT,N(I),NSPAN,ISN,IERR) IF (IERR .NE. 0) RETURN 20 CONTINUE RETURN C 30 IERR = 1 RETURN 40 IERR = 4 RETURN 50 IERR = 5 RETURN END SUBROUTINE SFFT(A,B,NTOT,N,NSPAN,ISN,IERR) C MULTIVARIATE COMPLEX FOURIER TRANSFORM, COMPUTED IN PLACE C USING MIXED-RADIX FAST FOURIER TRANSFORM ALGORITHM. C BY R. C. SINGLETON, STANFORD RESEARCH INSTITUTE, OCT. 1968 C MODIFIED BY A. H. MORRIS, NSWC/DL, DAHLGREN VA C ARRAYS A AND B ORIGINALLY HOLD THE REAL AND IMAGINARY C COMPONENTS OF THE DATA, AND RETURN THE REAL AND C IMAGINARY COMPONENTS OF THE RESULTING FOURIER COEFFICIENTS. C MULTIVARIATE DATA IS INDEXED ACCORDING TO THE FORTRAN C ARRAY ELEMENT SUCCESSOR FUNCTION, WITHOUT LIMIT C ON THE NUMBER OF IMPLIED MULTIPLE SUBSCRIPTS. C THE SUBROUTINE IS CALLED ONCE FOR EACH VARIATE. C THE CALLS FOR A MULTIVARIATE TRANSFORM MAY BE IN ANY ORDER. C NTOT IS THE TOTAL NUMBER OF COMPLEX DATA VALUES. C N IS THE DIMENSION OF THE CURRENT VARIABLE. C NSPAN/N IS THE SPACING OF CONSECUTIVE DATA VALUES C WHILE INDEXING THE CURRENT VARIABLE. C THE SIGN OF ISN DETERMINES THE SIGN OF THE COMPLEX C EXPONENTIAL, AND THE MAGNITUDE OF ISN IS NORMALLY ONE. C A TRI-VARIATE TRANSFORM WITH A(N1,N2,N3), B(N1,N2,N3) C IS COMPUTED BY C CALL SFFT(A,B,N1*N2*N3,N1,N1,1,IERR) C CALL SFFT(A,B,N1*N2*N3,N2,N1*N2,1,IERR) C CALL SFFT(A,B,N1*N2*N3,N3,N1*N2*N3,1,IERR) C FOR A SINGLE-VARIATE TRANSFORM, C NTOT = N = NSPAN = (NUMBER OF COMPLEX DATA VALUES), E.G. C CALL SFFT(A,B,N,N,N,1,IERR) C THE DATA MAY ALTERNATIVELY BE STORED IN A SINGLE COMPLEX C ARRAY A, THEN THE MAGNITUDE OF ISN CHANGED TO TWO TO C GIVE THE CORRECT INDEXING INCREMENT AND A(2) USED TO C PASS THE INITIAL ADDRESS FOR THE SEQUENCE OF IMAGINARY C VALUES, E.G. C CALL SFFT(A,A(2),NTOT,N,NSPAN,2,IERR) C ARRAYS NFAC(MAXN),NP(MAXP),AT(MAXF),CK(MAXF),BT(MAXF),SK(MAXF) C ARE USED FOR TEMPORARY STORAGE. C MAXN MUST BE .GE. THE NUMBER OF FACTORS OF N C MAXF MUST BE .GE. THE MAXIMUM PRIME FACTOR OF N. C MAXP MUST BE .GT. THE NUMBER OF PRIME FACTORS OF N. C IN ADDITION, MAXN IS ASSUMED TO BE ODD. C IF THE SQUARE-FREE PORTION K OF N HAS TWO OR MORE PRIME C FACTORS, THEN MAXP MUST BE .GE. K-1. C IERR IS A VARIABLE. IERR IS SET TO 0 IF NO INPUT ERRORS ARE C DETECTED. OTHERWISE, IERR IS ASSIGNED ONE OF THE VALUES C IERR=1 N IS LESS THAN 1 C IERR=2 N HAS MORE THAN MAXN FACTORS C IERR=3 N HAS A PRIME FACTOR GREATER THAN C MAXF OR THE SQUARE-FREE PORTION OF C N IS GREATER THAN MAXP+1 DIMENSION A(*),B(*) C ARRAY STORAGE IN NFAC FOR A MAXIMUM OF 15 FACTORS OF N. C IF N HAS MORE THAN ONE SQUARE-FREE FACTOR, THE PRODUCT OF THE C SQUARE-FREE FACTORS MUST BE .LE. 210 DIMENSION NFAC(15),NP(209) C ARRAY STORAGE FOR MAXIMUM PRIME FACTOR OF 23 DIMENSION AT(23),CK(23),BT(23),SK(23) EQUIVALENCE (I,II) C THE FOLLOWING CONSTANTS SHOULD AGREE WITH THE ARRAY DIMENSIONS. MAXN=15 MAXF=23 MAXP=209 C SET THE FOLLOWING CONSTANTS C RAD=2.0*PI C S72=SIN(RAD/5.0) C C72=COS(RAD/5.0) C S120=SQRT(0.75) RAD=6.2831853071796 S72=.951056516295154 C72=.309016994374947 S120=.86602540378444 C IERR=0 IF(N-1) 1000,960,5 5 INC=ISN IF(ISN .GE. 0) GO TO 10 S72=-S72 S120=-S120 RAD=-RAD INC=-INC 10 NT=INC*NTOT KS=INC*NSPAN KSPAN=KS NN=NT-INC JC=KS/N RADF=RAD*FLOAT(JC)*0.5 I=0 JF=0 C DETERMINE THE FACTORS OF N M=0 K=N MAX=MAXN/2 GO TO 20 15 IF(M .EQ. MAX) GO TO 1001 M=M+1 NFAC(M)=4 K=L 20 L=K/16 IF(K .EQ. L*16) GO TO 15 J=3 JJ=9 GO TO 30 25 IF(M .EQ. MAX) GO TO 1001 M=M+1 NFAC(M)=J K=K/JJ 30 IF(MOD(K,JJ) .EQ. 0) GO TO 25 J=J+2 JJ=J**2 IF(J .LE. MAXF .AND. JJ .LE. K) GO TO 30 IF(K .GT. 4) GO TO 40 KT=M NFAC(M+1)=K IF(K .NE. 1) M=M+1 GO TO 80 40 L=K/4 IF(K .NE. L*4) GO TO 50 IF(M .EQ. MAX) GO TO 1001 M=M+1 NFAC(M)=2 K=L KT=M IF(K .EQ. 1) GO TO 85 50 KT=M IF(K-1 .GT. MAXP) GO TO 1002 NUM=MAXN-KT-KT J=2 60 IF(MOD(K,J) .NE. 0) GO TO 70 M=M+1 NFAC(M)=J NUM=NUM-1 K=K/J IF(K .EQ. 1) GO TO 80 IF(NUM .LE. 0) GO TO 1001 70 L=(J+1)/2 J=L+L+1 IF(J .LE. MAXF) GO TO 60 GO TO 1002 80 IF(KT .EQ. 0) GO TO 100 85 J=KT 90 M=M+1 NFAC(M)=NFAC(J) J=J-1 IF(J .NE. 0) GO TO 90 C COMPUTE FOURIER TRANSFORM 100 SD=RADF/FLOAT(KSPAN) CD=2.0*SIN(SD)**2 SD=SIN(SD+SD) KK=1 I=I+1 IF(NFAC(I) .NE. 2) GO TO 400 C TRANSFORM FOR FACTOR OF 2 (INCLUDING ROTATION FACTOR) KSPAN=KSPAN/2 K1=KSPAN+2 210 K2=KK+KSPAN AK=A(K2) BK=B(K2) A(K2)=A(KK)-AK B(K2)=B(KK)-BK A(KK)=A(KK)+AK B(KK)=B(KK)+BK KK=K2+KSPAN IF(KK .LE. NN) GO TO 210 KK=KK-NN IF(KK .LE. JC) GO TO 210 IF(KK .GT. KSPAN) GO TO 800 220 C1=1.0-CD S1=SD 230 K2=KK+KSPAN AK=A(KK)-A(K2) BK=B(KK)-B(K2) A(KK)=A(KK)+A(K2) B(KK)=B(KK)+B(K2) A(K2)=C1*AK-S1*BK B(K2)=S1*AK+C1*BK KK=K2+KSPAN IF(KK .LT. NT) GO TO 230 K2=KK-NT C1=-C1 KK=K1-K2 IF(KK .GT. K2) GO TO 230 U=SD*S1+CD*C1 V=SD*C1-CD*S1 AK=C1-U S1=S1+V C THE FOLLOWING THREE STATEMENTS COMPENSATE FOR TRUNCATION ERROR. C IF ROUNDED ARITHMETIC IS USED THEN ONE MAY SUBSTITUTE C C1=AK C1=1.5-0.5*(AK*AK+S1*S1) S1=C1*S1 C1=C1*AK KK=KK+JC IF(KK .LT. K2) GO TO 230 K1=K1+INC+INC KK=(K1-KSPAN)/2+JC IF(KK .LE. JC+JC) GO TO 220 GO TO 100 C TRANSFORM FOR FACTOR OF 3 (OPTIONAL CODE) 320 K1=KK+KSPAN K2=K1+KSPAN AK=A(KK) BK=B(KK) AJ=A(K1)+A(K2) BJ=B(K1)+B(K2) A(KK)=AK+AJ B(KK)=BK+BJ AK=-0.5*AJ+AK BK=-0.5*BJ+BK AJ=(A(K1)-A(K2))*S120 BJ=(B(K1)-B(K2))*S120 A(K1)=AK-BJ B(K1)=BK+AJ A(K2)=AK+BJ B(K2)=BK-AJ KK=K2+KSPAN IF(KK .LT. NN) GO TO 320 KK=KK-NN IF(KK .LE. KSPAN) GO TO 320 GO TO 700 C TRANSFORM FOR FACTOR OF 4 400 IF(NFAC(I) .NE. 4) GO TO 600 KSPNN=KSPAN KSPAN=KSPAN/4 410 C1=1.0 S1=0.0 420 K1=KK+KSPAN K2=K1+KSPAN K3=K2+KSPAN AKP=A(KK)+A(K2) AKM=A(KK)-A(K2) AJP=A(K1)+A(K3) AJM=A(K1)-A(K3) A(KK)=AKP+AJP AJP=AKP-AJP BKP=B(KK)+B(K2) BKM=B(KK)-B(K2) BJP=B(K1)+B(K3) BJM=B(K1)-B(K3) B(KK)=BKP+BJP BJP=BKP-BJP IF(ISN .LT. 0) GO TO 450 AKP=AKM-BJM AKM=AKM+BJM BKP=BKM+AJM BKM=BKM-AJM IF(S1 .EQ. 0.0) GO TO 460 430 A(K1)=AKP*C1-BKP*S1 B(K1)=AKP*S1+BKP*C1 A(K2)=AJP*C2-BJP*S2 B(K2)=AJP*S2+BJP*C2 A(K3)=AKM*C3-BKM*S3 B(K3)=AKM*S3+BKM*C3 KK=K3+KSPAN IF(KK .LE. NT) GO TO 420 440 U=SD*S1+CD*C1 V=SD*C1-CD*S1 C2=C1-U S1=S1+V C THE FOLLOWING THREE STATEMENTS COMPENSATE FOR TRUNCATION ERROR. C IF ROUNDED ARITHMETIC IS USED THEN ONE MAY SUBSTITUTE C C1=C2 C1=1.5-0.5*(C2*C2+S1*S1) S1=C1*S1 C1=C1*C2 C2=C1*C1-S1*S1 S2=2.0*C1*S1 C3=C2*C1-S2*S1 S3=C2*S1+S2*C1 KK=KK-NT+JC IF(KK .LE. KSPAN) GO TO 420 KK=KK-KSPAN+INC IF(KK .LE. JC) GO TO 410 IF(KSPAN .EQ. JC) GO TO 800 GO TO 100 450 AKP=AKM+BJM AKM=AKM-BJM BKP=BKM-AJM BKM=BKM+AJM IF(S1 .NE. 0.0) GO TO 430 460 A(K1)=AKP B(K1)=BKP A(K2)=AJP B(K2)=BJP A(K3)=AKM B(K3)=BKM KK=K3+KSPAN IF(KK .LE. NT) GO TO 420 GO TO 440 C TRANSFORM FOR FACTOR OF 5 (OPTIONAL CODE) 510 C2=C72**2-S72**2 S2=2.0*C72*S72 520 K1=KK+KSPAN K2=K1+KSPAN K3=K2+KSPAN K4=K3+KSPAN AKP=A(K1)+A(K4) AKM=A(K1)-A(K4) BKP=B(K1)+B(K4) BKM=B(K1)-B(K4) AJP=A(K2)+A(K3) AJM=A(K2)-A(K3) BJP=B(K2)+B(K3) BJM=B(K2)-B(K3) AA=A(KK) BB=B(KK) A(KK)=AA+AKP+AJP B(KK)=BB+BKP+BJP AK=AKP*C72+AJP*C2+AA BK=BKP*C72+BJP*C2+BB AJ=AKM*S72+AJM*S2 BJ=BKM*S72+BJM*S2 A(K1)=AK-BJ A(K4)=AK+BJ B(K1)=BK+AJ B(K4)=BK-AJ AK=AKP*C2+AJP*C72+AA BK=BKP*C2+BJP*C72+BB AJ=AKM*S2-AJM*S72 BJ=BKM*S2-BJM*S72 A(K2)=AK-BJ A(K3)=AK+BJ B(K2)=BK+AJ B(K3)=BK-AJ KK=K4+KSPAN IF(KK .LT. NN) GO TO 520 KK=KK-NN IF(KK .LE. KSPAN) GO TO 520 GO TO 700 C TRANSFORM FOR ODD FACTORS 600 K=NFAC(I) KSPNN=KSPAN KSPAN=KSPAN/K IF(K .EQ. 3) GO TO 320 IF(K .EQ. 5) GO TO 510 IF(K .EQ. JF) GO TO 640 JF=K S1=RAD/FLOAT(K) C1=COS(S1) S1=SIN(S1) CK(JF)=1.0 SK(JF)=0.0 J=1 630 CK(J)=CK(K)*C1+SK(K)*S1 SK(J)=CK(K)*S1-SK(K)*C1 K=K-1 CK(K)=CK(J) SK(K)=-SK(J) J=J+1 IF(J .LT. K) GO TO 630 640 K1=KK K2=KK+KSPNN AA=A(KK) BB=B(KK) AK=AA BK=BB J=1 K1=K1+KSPAN 650 K2=K2-KSPAN J=J+1 AT(J)=A(K1)+A(K2) AK=AT(J)+AK BT(J)=B(K1)+B(K2) BK=BT(J)+BK J=J+1 AT(J)=A(K1)-A(K2) BT(J)=B(K1)-B(K2) K1=K1+KSPAN IF(K1 .LT. K2) GO TO 650 A(KK)=AK B(KK)=BK K1=KK K2=KK+KSPNN J=1 660 K1=K1+KSPAN K2=K2-KSPAN JJ=J AK=AA BK=BB AJ=0.0 BJ=0.0 K=1 670 K=K+1 AK=AT(K)*CK(JJ)+AK BK=BT(K)*CK(JJ)+BK K=K+1 AJ=AT(K)*SK(JJ)+AJ BJ=BT(K)*SK(JJ)+BJ JJ=JJ+J IF(JJ .GT. JF) JJ=JJ-JF IF(K .LT. JF) GO TO 670 K=JF-J A(K1)=AK-BJ B(K1)=BK+AJ A(K2)=AK+BJ B(K2)=BK-AJ J=J+1 IF(J .LT. K) GO TO 660 KK=KK+KSPNN IF(KK .LE. NN) GO TO 640 KK=KK-NN IF(KK .LE. KSPAN) GO TO 640 C MULTIPLY BY ROTATION FACTOR (EXCEPT FOR FACTORS OF 2 AND 4) 700 IF(I .EQ. M) GO TO 800 KK=JC+1 710 C2=1.0-CD S1=SD 720 C1=C2 S2=S1 KK=KK+KSPAN 730 AK=A(KK) A(KK)=C2*AK-S2*B(KK) B(KK)=S2*AK+C2*B(KK) KK=KK+KSPNN IF(KK .LE. NT) GO TO 730 AK=S1*S2 S2=S1*C2+C1*S2 C2=C1*C2-AK KK=KK-NT+KSPAN IF(KK .LE. KSPNN) GO TO 730 U=SD*S1+CD*C1 V=SD*C1-CD*S1 C2=C1-U S1=S1+V C THE FOLLOWING THREE STATEMENTS COMPENSATE FOR TRUNCATION C ERROR. IF ROUNDED ARITHMETIC IS USED THEN THEY MAY C BE DELETED. C1=1.5-0.5*(C2*C2+S1*S1) S1=C1*S1 C2=C1*C2 KK=KK-KSPNN+JC IF(KK .LE. KSPAN) GO TO 720 KK=KK-KSPAN+JC+INC IF(KK .LE. JC+JC) GO TO 710 GO TO 100 C PERMUTE THE RESULTS TO NORMAL ORDER---DONE IN TWO STAGES C PERMUTATION FOR SQUARE FACTORS OF N 800 NP(1)=KS IF(KT .EQ. 0) GO TO 890 K=KT+KT+1 IF(M .LT. K) K=K-1 J=1 NP(K+1)=JC 810 NP(J+1)=NP(J)/NFAC(J) NP(K)=NP(K+1)*NFAC(J) J=J+1 K=K-1 IF(J .LT. K) GO TO 810 K3=NP(K+1) KSPAN=NP(2) KK=JC+1 K2=KSPAN+1 J=1 IF(N .NE. NTOT) GO TO 850 C PERMUTATION FOR SINGLE-VARIATE TRANSFORM (OPTIONAL CODE) 820 AK=A(KK) A(KK)=A(K2) A(K2)=AK BK=B(KK) B(KK)=B(K2) B(K2)=BK KK=KK+INC K2=KSPAN+K2 IF(K2 .LT. KS) GO TO 820 830 K2=K2-NP(J) J=J+1 K2=NP(J+1)+K2 IF(K2 .GT. NP(J)) GO TO 830 J=1 840 IF(KK .LT. K2) GO TO 820 KK=KK+INC K2=KSPAN+K2 IF(K2 .LT. KS) GO TO 840 IF(KK .LT. KS) GO TO 830 JC=K3 GO TO 890 C PERMUTATION FOR MULTIVARIATE TRANSFORM 850 K=KK+JC 860 AK=A(KK) A(KK)=A(K2) A(K2)=AK BK=B(KK) B(KK)=B(K2) B(K2)=BK KK=KK+INC K2=K2+INC IF(KK .LT. K) GO TO 860 KK=KK+KS-JC K2=K2+KS-JC IF(KK .LT. NT) GO TO 850 K2=K2-NT+KSPAN KK=KK-NT+JC IF(K2 .LT. KS) GO TO 850 870 K2=K2-NP(J) J=J+1 K2=NP(J+1)+K2 IF(K2 .GT. NP(J)) GO TO 870 J=1 880 IF(KK .LT. K2) GO TO 850 KK=KK+JC K2=KSPAN+K2 IF(K2 .LT. KS) GO TO 880 IF(KK .LT. KS) GO TO 870 JC=K3 890 IF(2*KT+1 .GE. M) RETURN KSPNN=NP(KT+1) C PERMUTATION FOR SQUARE-FREE FACTORS OF N J=M-KT NFAC(J+1)=1 900 NFAC(J)=NFAC(J)*NFAC(J+1) J=J-1 IF(J .NE. KT) GO TO 900 KT=KT+1 NN=NFAC(KT)-1 JJ=0 J=0 GO TO 906 902 JJ=JJ-K2 K2=KK K=K+1 KK=NFAC(K) 904 JJ=KK+JJ IF(JJ .GE. K2) GO TO 902 NP(J)=JJ 906 K2=NFAC(KT) K=KT+1 KK=NFAC(K) J=J+1 IF(J .LE. NN) GO TO 904 C DETERMINE THE PERMUTATION CYCLES OF LENGTH GREATER THAN 1 J=0 GO TO 914 910 K=KK KK=NP(K) NP(K)=-KK IF(KK .NE. J) GO TO 910 K3=KK 914 J=J+1 KK=NP(J) IF(KK .LT. 0) GO TO 914 IF(KK .NE. J) GO TO 910 NP(J)=-J IF(J .NE. NN) GO TO 914 MAXF=INC*MAXF C REORDER A AND B, FOLLOWING THE PERMUTATION CYCLES GO TO 950 924 J=J-1 IF(NP(J) .LT. 0) GO TO 924 JJ=JC 926 KSPAN=JJ IF(JJ .GT. MAXF) KSPAN=MAXF JJ=JJ-KSPAN K=NP(J) KK=JC*K+II+JJ K1=KK+KSPAN K2=0 928 K2=K2+1 AT(K2)=A(K1) BT(K2)=B(K1) K1=K1-INC IF(K1 .NE. KK) GO TO 928 932 K1=KK+KSPAN K2=K1-JC*(K+NP(K)) K=-NP(K) 936 A(K1)=A(K2) B(K1)=B(K2) K1=K1-INC K2=K2-INC IF(K1 .NE. KK) GO TO 936 KK=K2 IF(K .NE. J) GO TO 932 K1=KK+KSPAN K2=0 940 K2=K2+1 A(K1)=AT(K2) B(K1)=BT(K2) K1=K1-INC IF(K1 .NE. KK) GO TO 940 IF(JJ .NE. 0) GO TO 926 IF(J .NE. 1) GO TO 924 950 J=K3+1 NT=NT-KSPNN II=NT-INC+1 IF(NT .GE. 0) GO TO 924 960 RETURN C ERROR FINISH - THERE IS AN INPUT ERROR 1000 IERR=1 RETURN 1001 IERR=2 RETURN 1002 IERR=3 RETURN END C ****************************************************************** C C SUBROUTINE COSQI(N,WSAVE) C C ****************************************************************** C C SUBROUTINE COSQI INITIALIZES THE ARRAY WSAVE WHICH IS USED IN C BOTH COSQF AND COSQB. THE PRIME FACTORIZATION OF N TOGETHER WITH C A TABULATION OF THE TRIGONOMETRIC FUNCTIONS ARE COMPUTED AND C STORED IN WSAVE. C C INPUT PARAMETER C C N THE LENGTH OF THE ARRAY TO BE TRANSFORMED. THE METHOD C IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES. C C OUTPUT PARAMETER C C WSAVE A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 3*N+15. C THE SAME WORK ARRAY CAN BE USED FOR BOTH COSQF AND COSQB C AS LONG AS N REMAINS UNCHANGED. DIFFERENT WSAVE ARRAYS C ARE REQUIRED FOR DIFFERENT VALUES OF N. THE CONTENTS OF C WSAVE MUST NOT BE CHANGED BETWEEN CALLS OF COSQF OR COSQB. C SUBROUTINE COSQI (N,WSAVE) DIMENSION WSAVE(*) DATA PIH /1.57079632679491/ DT = PIH/FLOAT(N) FK = 0. DO 101 K=1,N FK = FK+1. WSAVE(K) = COS(FK*DT) 101 CONTINUE CALL RFFTI (N,WSAVE(N+1)) RETURN END C ****************************************************************** C C SUBROUTINE COSQF(N,X,WSAVE) C C ****************************************************************** C C SUBROUTINE COSQF COMPUTES THE FAST FOURIER TRANSFORM OF QUARTER C WAVE DATA. THAT IS , COSQF COMPUTES THE COEFFICIENTS IN A COSINE C SERIES REPRESENTATION WITH ONLY ODD WAVE NUMBERS. THE TRANSFORM C IS DEFINED BELOW AT OUTPUT PARAMETER X C C COSQF IS THE UNNORMALIZED INVERSE OF COSQB SINCE A CALL OF COSQF C FOLLOWED BY A CALL OF COSQB WILL MULTIPLY THE INPUT SEQUENCE X C BY 4*N. C C THE ARRAY WSAVE WHICH IS USED BY SUBROUTINE COSQF MUST BE C INITIALIZED BY CALLING SUBROUTINE COSQI(N,WSAVE). C C C INPUT PARAMETERS C C N THE LENGTH OF THE ARRAY X TO BE TRANSFORMED. THE METHOD C IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES. C C X AN ARRAY WHICH CONTAINS THE SEQUENCE TO BE TRANSFORMED C C WSAVE A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 3*N+15 C IN THE PROGRAM THAT CALLS COSQF. THE WSAVE ARRAY MUST BE C INITIALIZED BY CALLING SUBROUTINE COSQI(N,WSAVE) AND A C DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT C VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE C REPEATED SO LONG AS N REMAINS UNCHANGED THUS SUBSEQUENT C TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST. C C OUTPUT PARAMETERS C C X FOR I=1,...,N C C X(I) = X(1) PLUS THE SUM FROM K=2 TO K=N OF C C 2*X(K)*COS((2*I-1)*(K-1)*PI/(2*N)) C C A CALL OF COSQF FOLLOWED BY A CALL OF C COSQB WILL MULTIPLY THE SEQUENCE X BY 4*N. C THEREFORE COSQB IS THE UNNORMALIZED INVERSE C OF COSQF. C C WSAVE CONTAINS INITIALIZATION CALCULATIONS WHICH MUST NOT C BE DESTROYED BETWEEN CALLS OF COSQF OR COSQB. C SUBROUTINE COSQF (N,X,WSAVE) DIMENSION X(*), WSAVE(*) DATA SQRT2 /1.4142135623731/ IF (N-2) 102,101,103 101 TSQX = SQRT2*X(2) X(2) = X(1)-TSQX X(1) = X(1)+TSQX 102 RETURN 103 CALL COSQF1 (N,X,WSAVE,WSAVE(N+1)) RETURN END SUBROUTINE COSQF1 (N,X,W,XH) DIMENSION X(*) ,W(*) ,XH(*) NS2 = (N+1)/2 NP2 = N+2 DO 101 K=2,NS2 KC = NP2-K XH(K) = X(K)+X(KC) XH(KC) = X(K)-X(KC) 101 CONTINUE MODN = MOD(N,2) IF (MODN .EQ. 0) XH(NS2+1) = X(NS2+1)+X(NS2+1) DO 102 K=2,NS2 KC = NP2-K X(K) = W(K-1)*XH(KC)+W(KC-1)*XH(K) X(KC) = W(K-1)*XH(K)-W(KC-1)*XH(KC) 102 CONTINUE IF (MODN .EQ. 0) X(NS2+1) = W(NS2)*XH(NS2+1) CALL RFFTF (N,X,XH) DO 103 I=3,N,2 XIM1 = X(I-1)-X(I) X(I) = X(I-1)+X(I) X(I-1) = XIM1 103 CONTINUE RETURN END C ****************************************************************** C C SUBROUTINE COSQB(N,X,WSAVE) C C ****************************************************************** C C SUBROUTINE COSQB COMPUTES THE FAST FOURIER TRANSFORM OF QUARTER C WAVE DATA. THAT IS , COSQB COMPUTES A SEQUENCE FROM ITS C REPRESENTATION IN TERMS OF A COSINE SERIES WITH ODD WAVE NUMBERS. C THE TRANSFORM IS DEFINED BELOW AT OUTPUT PARAMETER X. C C COSQB IS THE UNNORMALIZED INVERSE OF COSQF SINCE A CALL OF COSQB C FOLLOWED BY A CALL OF COSQF WILL MULTIPLY THE INPUT SEQUENCE X C BY 4*N. C C THE ARRAY WSAVE WHICH IS USED BY SUBROUTINE COSQB MUST BE C INITIALIZED BY CALLING SUBROUTINE COSQI(N,WSAVE). C C C INPUT PARAMETERS C C N THE LENGTH OF THE ARRAY X TO BE TRANSFORMED. THE METHOD C IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES. C C X AN ARRAY WHICH CONTAINS THE SEQUENCE TO BE TRANSFORMED C C WSAVE A WORK ARRAY THAT MUST BE DIMENSIONED AT LEAST 3*N+15 C IN THE PROGRAM THAT CALLS COSQB. THE WSAVE ARRAY MUST BE C INITIALIZED BY CALLING SUBROUTINE COSQI(N,WSAVE) AND A C DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT C VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE C REPEATED SO LONG AS N REMAINS UNCHANGED THUS SUBSEQUENT C TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST. C C OUTPUT PARAMETERS C C X FOR I=1,...,N C C X(I)= THE SUM FROM K=1 TO K=N OF C C 4*X(K)*COS((2*K-1)*(I-1)*PI/(2*N)) C C A CALL OF COSQB FOLLOWED BY A CALL OF C COSQF WILL MULTIPLY THE SEQUENCE X BY 4*N. C THEREFORE COSQF IS THE UNNORMALIZED INVERSE C OF COSQB. C C WSAVE CONTAINS INITIALIZATION CALCULATIONS WHICH MUST NOT C BE DESTROYED BETWEEN CALLS OF COSQB OR COSQF. C SUBROUTINE COSQB (N,X,WSAVE) DIMENSION X(*), WSAVE(*) DATA TSQRT2 /2.82842712474619/ IF (N-2) 101,102,103 101 X(1) = 4.*X(1) RETURN 102 X1 = 4.*(X(1)+X(2)) X(2) = TSQRT2*(X(1)-X(2)) X(1) = X1 RETURN 103 CALL COSQB1 (N,X,WSAVE,WSAVE(N+1)) RETURN END SUBROUTINE COSQB1 (N,X,W,XH) DIMENSION X(*) ,W(*) ,XH(*) NS2 = (N+1)/2 NP2 = N+2 DO 101 I=3,N,2 XIM1 = X(I-1)+X(I) X(I) = X(I)-X(I-1) X(I-1) = XIM1 101 CONTINUE X(1) = X(1)+X(1) MODN = MOD(N,2) IF (MODN .EQ. 0) X(N) = X(N)+X(N) CALL RFFTB (N,X,XH) DO 102 K=2,NS2 KC = NP2-K XH(K) = W(K-1)*X(KC)+W(KC-1)*X(K) XH(KC) = W(K-1)*X(K)-W(KC-1)*X(KC) 102 CONTINUE IF (MODN .EQ. 0) X(NS2+1) = W(NS2)*(X(NS2+1)+X(NS2+1)) DO 103 K=2,NS2 KC = NP2-K X(K) = XH(K)+XH(KC) X(KC) = XH(K)-XH(KC) 103 CONTINUE X(1) = X(1)+X(1) RETURN END C ****************************************************************** C C SUBROUTINE SINQF(N,X,WSAVE) C C ****************************************************************** C C SUBROUTINE SINQF COMPUTES THE FAST FOURIER TRANSFORM OF QUARTER C WAVE DATA. THAT IS , SINQF COMPUTES THE COEFFICIENTS IN A SINE C SERIES REPRESENTATION WITH ONLY ODD WAVE NUMBERS. THE TRANSFORM C IS DEFINED BELOW AT OUTPUT PARAMETER X. C C SINQB IS THE UNNORMALIZED INVERSE OF SINQF SINCE A CALL OF SINQF C FOLLOWED BY A CALL OF SINQB WILL MULTIPLY THE INPUT SEQUENCE X C BY 4*N. C C THE ARRAY WSAVE WHICH IS USED BY SUBROUTINE SINQF MUST BE C INITIALIZED BY CALLING SUBROUTINE SINQI(N,WSAVE). C C C INPUT PARAMETERS C C N THE LENGTH OF THE ARRAY X TO BE TRANSFORMED. THE METHOD C IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES. C C X AN ARRAY WHICH CONTAINS THE SEQUENCE TO BE TRANSFORMED C C WSAVE A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 3*N+15. C IN THE PROGRAM THAT CALLS SINQF. THE WSAVE ARRAY MUST BE C INITIALIZED BY CALLING SUBROUTINE SINQI(N,WSAVE) AND A C DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT C VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE C REPEATED SO LONG AS N REMAINS UNCHANGED THUS SUBSEQUENT C TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST. C C OUTPUT PARAMETERS C C X FOR I=1,...,N C C X(I) = (-1)**(I-1)*X(N) C C + THE SUM FROM K=1 TO K=N-1 OF C C 2*X(K)*SIN((2*I-1)*K*PI/(2*N)) C C A CALL OF SINQF FOLLOWED BY A CALL OF C SINQB WILL MULTIPLY THE SEQUENCE X BY 4*N. C THEREFORE SINQB IS THE UNNORMALIZED INVERSE C OF SINQF. C C WSAVE CONTAINS INITIALIZATION CALCULATIONS WHICH MUST NOT C BE DESTROYED BETWEEN CALLS OF SINQF OR SINQB. C SUBROUTINE SINQF (N,X,WSAVE) DIMENSION X(*) ,WSAVE(*) IF (N .EQ. 1) RETURN NS2 = N/2 DO 101 K=1,NS2 KC = N-K XHOLD = X(K) X(K) = X(KC+1) X(KC+1) = XHOLD 101 CONTINUE CALL COSQF (N,X,WSAVE) DO 102 K=2,N,2 X(K) = -X(K) 102 CONTINUE RETURN END C ****************************************************************** C C SUBROUTINE SINQB(N,X,WSAVE) C C ****************************************************************** C C SUBROUTINE SINQB COMPUTES THE FAST FOURIER TRANSFORM OF QUARTER C WAVE DATA. THAT IS , SINQB COMPUTES A SEQUENCE FROM ITS C REPRESENTATION IN TERMS OF A SINE SERIES WITH ODD WAVE NUMBERS. C THE TRANSFORM IS DEFINED BELOW AT OUTPUT PARAMETER X. C C SINQF IS THE UNNORMALIZED INVERSE OF SINQB SINCE A CALL OF SINQB C FOLLOWED BY A CALL OF SINQF WILL MULTIPLY THE INPUT SEQUENCE X C BY 4*N. C C THE ARRAY WSAVE WHICH IS USED BY SUBROUTINE SINQB MUST BE C INITIALIZED BY CALLING SUBROUTINE SINQI(N,WSAVE). C C C INPUT PARAMETERS C C N THE LENGTH OF THE ARRAY X TO BE TRANSFORMED. THE METHOD C IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES. C C X AN ARRAY WHICH CONTAINS THE SEQUENCE TO BE TRANSFORMED C C WSAVE A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 3*N+15. C IN THE PROGRAM THAT CALLS SINQB. THE WSAVE ARRAY MUST BE C INITIALIZED BY CALLING SUBROUTINE SINQI(N,WSAVE) AND A C DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT C VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE C REPEATED SO LONG AS N REMAINS UNCHANGED THUS SUBSEQUENT C TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST. C C OUTPUT PARAMETERS C C X FOR I=1,...,N C C X(I)= THE SUM FROM K=1 TO K=N OF C C 4*X(K)*SIN((2K-1)*I*PI/(2*N)) C C A CALL OF SINQB FOLLOWED BY A CALL OF C SINQF WILL MULTIPLY THE SEQUENCE X BY 4*N. C THEREFORE SINQF IS THE UNNORMALIZED INVERSE C OF SINQB. C C WSAVE CONTAINS INITIALIZATION CALCULATIONS WHICH MUST NOT C BE DESTROYED BETWEEN CALLS OF SINQB OR SINQF. C SUBROUTINE SINQB (N,X,WSAVE) DIMENSION X(*) ,WSAVE(*) IF (N .GT. 1) GO TO 101 X(1) = 4.*X(1) RETURN 101 NS2 = N/2 DO 102 K=2,N,2 X(K) = -X(K) 102 CONTINUE CALL COSQB (N,X,WSAVE) DO 103 K=1,NS2 KC = N-K XHOLD = X(K) X(K) = X(KC+1) X(KC+1) = XHOLD 103 CONTINUE RETURN END C ****************************************************************** C C SUBROUTINE RFFTI(N,WSAVE) C C **************************************************************** C C SUBROUTINE RFFTI INITIALIZES THE ARRAY WSAVE WHICH IS USED IN C BOTH RFFTF AND RFFTB. THE PRIME FACTORIZATION OF N TOGETHER WITH C A TABULATION OF THE TRIGONOMETRIC FUNCTIONS ARE COMPUTED AND C STORED IN WSAVE. C C INPUT PARAMETER C C N THE LENGTH OF THE SEQUENCE TO BE TRANSFORMED. C C OUTPUT PARAMETER C C WSAVE A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 2*N+15. C THE SAME WORK ARRAY CAN BE USED FOR BOTH RFFTF AND RFFTB C AS LONG AS N REMAINS UNCHANGED. DIFFERENT WSAVE ARRAYS C ARE REQUIRED FOR DIFFERENT VALUES OF N. THE CONTENTS OF C WSAVE MUST NOT BE CHANGED BETWEEN CALLS OF RFFTF OR RFFTB. C SUBROUTINE RFFTI (N,WSAVE) DIMENSION WSAVE(*) IF (N .EQ. 1) RETURN CALL RFFTI1 (N,WSAVE(N+1),WSAVE(2*N+1)) RETURN END SUBROUTINE RFFTI1 (N,WA,IFAC) REAL WA(*), IFAC(*) INTEGER NTRYH(4) DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/ 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 TPI = 6.28318530717959 ARGH = TPI/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. 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 C ****************************************************************** C C SUBROUTINE RFFTB(N,R,WSAVE) C C ****************************************************************** C C SUBROUTINE RFFTB COMPUTES THE REAL PERODIC SEQUENCE FROM ITS C FOURIER COEFFICIENTS (FOURIER SYNTHESIS). THE TRANSFORM IS DEFINED C BELOW AT OUTPUT PARAMETER R. C C INPUT PARAMETERS C C N THE LENGTH OF THE ARRAY R TO BE TRANSFORMED. THE METHOD C IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES. C N MAY CHANGE SO LONG AS DIFFERENT WORK ARRAYS ARE PROVIDED C C R A REAL ARRAY OF LENGTH N WHICH CONTAINS THE SEQUENCE C TO BE TRANSFORMED C C WSAVE A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 2*N+15. C IN THE PROGRAM THAT CALLS RFFTB. THE WSAVE ARRAY MUST BE C INITIALIZED BY CALLING SUBROUTINE RFFTI(N,WSAVE) AND A C DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT C VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE C REPEATED SO LONG AS N REMAINS UNCHANGED THUS SUBSEQUENT C TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST. C THE SAME WSAVE ARRAY CAN BE USED BY RFFTF AND RFFTB. C C C OUTPUT PARAMETERS C C R FOR N EVEN AND FOR I = 1,...,N C C R(I) = R(1)+(-1)**(I-1)*R(N) C C PLUS THE SUM FROM K=2 TO K=N/2 OF C C 2.*R(2*K-2)*COS((K-1)*(I-1)*2*PI/N) C C -2.*R(2*K-1)*SIN((K-1)*(I-1)*2*PI/N) C C FOR N ODD AND FOR I = 1,...,N C C R(I) = R(1) PLUS THE SUM FROM K=2 TO K=(N+1)/2 OF C C 2.*R(2*K-2)*COS((K-1)*(I-1)*2*PI/N) C C -2.*R(2*K-1)*SIN((K-1)*(I-1)*2*PI/N) C C ***** NOTE C THIS TRANSFORM IS UNNORMALIZED SINCE A CALL OF RFFTF C FOLLOWED BY A CALL OF RFFTB WILL MULTIPLY THE INPUT C SEQUENCE BY N. C C WSAVE CONTAINS RESULTS WHICH MUST NOT BE DESTROYED BETWEEN C CALLS OF RFFTB OR RFFTF. C C SUBROUTINE RFFTB (N,R,WSAVE) DIMENSION R(*) ,WSAVE(*) IF (N .EQ. 1) RETURN CALL RFFTB1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1)) RETURN END SUBROUTINE RFFTB1 (N,C,CH,WA,IFAC) REAL C(*), CH(*), WA(*), IFAC(*) NF = IFAC(2) NA = 0 L1 = 1 IW = 1 DO 116 K1=1,NF IP = IFAC(K1+2) L2 = IP*L1 IDO = N/L2 IDL1 = IDO*L1 IF (IP .NE. 4) GO TO 103 IX2 = IW+IDO IX3 = IX2+IDO IF (NA .NE. 0) GO TO 101 CALL RADB4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) GO TO 102 101 CALL RADB4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) 102 NA = 1-NA GO TO 115 103 IF (IP .NE. 2) GO TO 106 IF (NA .NE. 0) GO TO 104 CALL RADB2 (IDO,L1,C,CH,WA(IW)) GO TO 105 104 CALL RADB2 (IDO,L1,CH,C,WA(IW)) 105 NA = 1-NA GO TO 115 106 IF (IP .NE. 3) GO TO 109 IX2 = IW+IDO IF (NA .NE. 0) GO TO 107 CALL RADB3 (IDO,L1,C,CH,WA(IW),WA(IX2)) GO TO 108 107 CALL RADB3 (IDO,L1,CH,C,WA(IW),WA(IX2)) 108 NA = 1-NA GO TO 115 109 IF (IP .NE. 5) GO TO 112 IX2 = IW+IDO IX3 = IX2+IDO IX4 = IX3+IDO IF (NA .NE. 0) GO TO 110 CALL RADB5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) GO TO 111 110 CALL RADB5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) 111 NA = 1-NA GO TO 115 112 IF (NA .NE. 0) GO TO 113 CALL RADBG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) GO TO 114 113 CALL RADBG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) 114 IF (IDO .EQ. 1) NA = 1-NA 115 L1 = L2 IW = IW+(IP-1)*IDO 116 CONTINUE IF (NA .EQ. 0) RETURN DO 117 I=1,N C(I) = CH(I) 117 CONTINUE RETURN END SUBROUTINE RADB2 (IDO,L1,CC,CH,WA1) DIMENSION CC(IDO,2,L1) ,CH(IDO,L1,*) , 1 WA1(*) DO 101 K=1,L1 CH(1,K,1) = CC(1,1,K)+CC(IDO,2,K) CH(1,K,2) = CC(1,1,K)-CC(IDO,2,K) 101 CONTINUE IF (IDO-2) 107,105,102 102 IDP2 = IDO+2 IF((IDO-1)/2.LT.L1) GO TO 108 DO 104 K=1,L1 DO 103 I=3,IDO,2 IC = IDP2-I CH(I-1,K,1) = CC(I-1,1,K)+CC(IC-1,2,K) TR2 = CC(I-1,1,K)-CC(IC-1,2,K) CH(I,K,1) = CC(I,1,K)-CC(IC,2,K) TI2 = CC(I,1,K)+CC(IC,2,K) CH(I-1,K,2) = WA1(I-2)*TR2-WA1(I-1)*TI2 CH(I,K,2) = WA1(I-2)*TI2+WA1(I-1)*TR2 103 CONTINUE 104 CONTINUE GO TO 111 108 DO 110 I=3,IDO,2 IC = IDP2-I DO 109 K=1,L1 CH(I-1,K,1) = CC(I-1,1,K)+CC(IC-1,2,K) TR2 = CC(I-1,1,K)-CC(IC-1,2,K) CH(I,K,1) = CC(I,1,K)-CC(IC,2,K) TI2 = CC(I,1,K)+CC(IC,2,K) CH(I-1,K,2) = WA1(I-2)*TR2-WA1(I-1)*TI2 CH(I,K,2) = WA1(I-2)*TI2+WA1(I-1)*TR2 109 CONTINUE 110 CONTINUE 111 IF (MOD(IDO,2) .EQ. 1) RETURN 105 DO 106 K=1,L1 CH(IDO,K,1) = CC(IDO,1,K)+CC(IDO,1,K) CH(IDO,K,2) = -(CC(1,2,K)+CC(1,2,K)) 106 CONTINUE 107 RETURN END SUBROUTINE RADB3 (IDO,L1,CC,CH,WA1,WA2) DIMENSION CC(IDO,3,L1) ,CH(IDO,L1,*) , 1 WA1(*) ,WA2(*) DATA TAUR,TAUI /-.5,.866025403784439/ DO 101 K=1,L1 TR2 = CC(IDO,2,K)+CC(IDO,2,K) CR2 = CC(1,1,K)+TAUR*TR2 CH(1,K,1) = CC(1,1,K)+TR2 CI3 = TAUI*(CC(1,3,K)+CC(1,3,K)) CH(1,K,2) = CR2-CI3 CH(1,K,3) = CR2+CI3 101 CONTINUE IF (IDO .EQ. 1) RETURN IDP2 = IDO+2 IF((IDO-1)/2.LT.L1) GO TO 104 DO 103 K=1,L1 DO 102 I=3,IDO,2 IC = IDP2-I TR2 = CC(I-1,3,K)+CC(IC-1,2,K) CR2 = CC(I-1,1,K)+TAUR*TR2 CH(I-1,K,1) = CC(I-1,1,K)+TR2 TI2 = CC(I,3,K)-CC(IC,2,K) CI2 = CC(I,1,K)+TAUR*TI2 CH(I,K,1) = CC(I,1,K)+TI2 CR3 = TAUI*(CC(I-1,3,K)-CC(IC-1,2,K)) CI3 = TAUI*(CC(I,3,K)+CC(IC,2,K)) DR2 = CR2-CI3 DR3 = CR2+CI3 DI2 = CI2+CR3 DI3 = CI2-CR3 CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2 CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2 CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3 CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3 102 CONTINUE 103 CONTINUE RETURN 104 DO 106 I=3,IDO,2 IC = IDP2-I DO 105 K=1,L1 TR2 = CC(I-1,3,K)+CC(IC-1,2,K) CR2 = CC(I-1,1,K)+TAUR*TR2 CH(I-1,K,1) = CC(I-1,1,K)+TR2 TI2 = CC(I,3,K)-CC(IC,2,K) CI2 = CC(I,1,K)+TAUR*TI2 CH(I,K,1) = CC(I,1,K)+TI2 CR3 = TAUI*(CC(I-1,3,K)-CC(IC-1,2,K)) CI3 = TAUI*(CC(I,3,K)+CC(IC,2,K)) DR2 = CR2-CI3 DR3 = CR2+CI3 DI2 = CI2+CR3 DI3 = CI2-CR3 CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2 CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2 CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3 CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3 105 CONTINUE 106 CONTINUE RETURN END SUBROUTINE RADB4 (IDO,L1,CC,CH,WA1,WA2,WA3) DIMENSION CC(IDO,4,L1) ,CH(IDO,L1,*) , 1 WA1(*) ,WA2(*) ,WA3(*) DATA SQRT2 /1.414213562373095/ DO 101 K=1,L1 TR1 = CC(1,1,K)-CC(IDO,4,K) TR2 = CC(1,1,K)+CC(IDO,4,K) TR3 = CC(IDO,2,K)+CC(IDO,2,K) TR4 = CC(1,3,K)+CC(1,3,K) CH(1,K,1) = TR2+TR3 CH(1,K,2) = TR1-TR4 CH(1,K,3) = TR2-TR3 CH(1,K,4) = TR1+TR4 101 CONTINUE IF (IDO-2) 107,105,102 102 IDP2 = IDO+2 IF((IDO-1)/2.LT.L1) GO TO 108 DO 104 K=1,L1 DO 103 I=3,IDO,2 IC = IDP2-I TI1 = CC(I,1,K)+CC(IC,4,K) TI2 = CC(I,1,K)-CC(IC,4,K) TI3 = CC(I,3,K)-CC(IC,2,K) TR4 = CC(I,3,K)+CC(IC,2,K) TR1 = CC(I-1,1,K)-CC(IC-1,4,K) TR2 = CC(I-1,1,K)+CC(IC-1,4,K) TI4 = CC(I-1,3,K)-CC(IC-1,2,K) TR3 = CC(I-1,3,K)+CC(IC-1,2,K) CH(I-1,K,1) = TR2+TR3 CR3 = TR2-TR3 CH(I,K,1) = TI2+TI3 CI3 = TI2-TI3 CR2 = TR1-TR4 CR4 = TR1+TR4 CI2 = TI1+TI4 CI4 = TI1-TI4 CH(I-1,K,2) = WA1(I-2)*CR2-WA1(I-1)*CI2 CH(I,K,2) = WA1(I-2)*CI2+WA1(I-1)*CR2 CH(I-1,K,3) = WA2(I-2)*CR3-WA2(I-1)*CI3 CH(I,K,3) = WA2(I-2)*CI3+WA2(I-1)*CR3 CH(I-1,K,4) = WA3(I-2)*CR4-WA3(I-1)*CI4 CH(I,K,4) = WA3(I-2)*CI4+WA3(I-1)*CR4 103 CONTINUE 104 CONTINUE GO TO 111 108 DO 110 I=3,IDO,2 IC = IDP2-I DO 109 K=1,L1 TI1 = CC(I,1,K)+CC(IC,4,K) TI2 = CC(I,1,K)-CC(IC,4,K) TI3 = CC(I,3,K)-CC(IC,2,K) TR4 = CC(I,3,K)+CC(IC,2,K) TR1 = CC(I-1,1,K)-CC(IC-1,4,K) TR2 = CC(I-1,1,K)+CC(IC-1,4,K) TI4 = CC(I-1,3,K)-CC(IC-1,2,K) TR3 = CC(I-1,3,K)+CC(IC-1,2,K) CH(I-1,K,1) = TR2+TR3 CR3 = TR2-TR3 CH(I,K,1) = TI2+TI3 CI3 = TI2-TI3 CR2 = TR1-TR4 CR4 = TR1+TR4 CI2 = TI1+TI4 CI4 = TI1-TI4 CH(I-1,K,2) = WA1(I-2)*CR2-WA1(I-1)*CI2 CH(I,K,2) = WA1(I-2)*CI2+WA1(I-1)*CR2 CH(I-1,K,3) = WA2(I-2)*CR3-WA2(I-1)*CI3 CH(I,K,3) = WA2(I-2)*CI3+WA2(I-1)*CR3 CH(I-1,K,4) = WA3(I-2)*CR4-WA3(I-1)*CI4 CH(I,K,4) = WA3(I-2)*CI4+WA3(I-1)*CR4 109 CONTINUE 110 CONTINUE 111 IF (MOD(IDO,2) .EQ. 1) RETURN 105 DO 106 K=1,L1 TI1 = CC(1,2,K)+CC(1,4,K) TI2 = CC(1,4,K)-CC(1,2,K) TR1 = CC(IDO,1,K)-CC(IDO,3,K) TR2 = CC(IDO,1,K)+CC(IDO,3,K) CH(IDO,K,1) = TR2+TR2 CH(IDO,K,2) = SQRT2*(TR1-TI1) CH(IDO,K,3) = TI2+TI2 CH(IDO,K,4) = -SQRT2*(TR1+TI1) 106 CONTINUE 107 RETURN END SUBROUTINE RADB5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) DIMENSION CC(IDO,5,L1) ,CH(IDO,L1,*) , 1 WA1(*) ,WA2(*) ,WA3(*) ,WA4(*) DATA TR11,TI11,TR12,TI12 /.309016994374947,.951056516295154, 1-.809016994374947,.587785252292473/ DO 101 K=1,L1 TI5 = CC(1,3,K)+CC(1,3,K) TI4 = CC(1,5,K)+CC(1,5,K) TR2 = CC(IDO,2,K)+CC(IDO,2,K) TR3 = CC(IDO,4,K)+CC(IDO,4,K) CH(1,K,1) = CC(1,1,K)+TR2+TR3 CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3 CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3 CI5 = TI11*TI5+TI12*TI4 CI4 = TI12*TI5-TI11*TI4 CH(1,K,2) = CR2-CI5 CH(1,K,3) = CR3-CI4 CH(1,K,4) = CR3+CI4 CH(1,K,5) = CR2+CI5 101 CONTINUE IF (IDO .EQ. 1) RETURN IDP2 = IDO+2 IF((IDO-1)/2.LT.L1) GO TO 104 DO 103 K=1,L1 DO 102 I=3,IDO,2 IC = IDP2-I TI5 = CC(I,3,K)+CC(IC,2,K) TI2 = CC(I,3,K)-CC(IC,2,K) TI4 = CC(I,5,K)+CC(IC,4,K) TI3 = CC(I,5,K)-CC(IC,4,K) TR5 = CC(I-1,3,K)-CC(IC-1,2,K) TR2 = CC(I-1,3,K)+CC(IC-1,2,K) TR4 = CC(I-1,5,K)-CC(IC-1,4,K) TR3 = CC(I-1,5,K)+CC(IC-1,4,K) CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 CH(I,K,1) = CC(I,1,K)+TI2+TI3 CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 CR5 = TI11*TR5+TI12*TR4 CI5 = TI11*TI5+TI12*TI4 CR4 = TI12*TR5-TI11*TR4 CI4 = TI12*TI5-TI11*TI4 DR3 = CR3-CI4 DR4 = CR3+CI4 DI3 = CI3+CR4 DI4 = CI3-CR4 DR5 = CR2+CI5 DR2 = CR2-CI5 DI5 = CI2-CR5 DI2 = CI2+CR5 CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2 CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2 CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3 CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3 CH(I-1,K,4) = WA3(I-2)*DR4-WA3(I-1)*DI4 CH(I,K,4) = WA3(I-2)*DI4+WA3(I-1)*DR4 CH(I-1,K,5) = WA4(I-2)*DR5-WA4(I-1)*DI5 CH(I,K,5) = WA4(I-2)*DI5+WA4(I-1)*DR5 102 CONTINUE 103 CONTINUE RETURN 104 DO 106 I=3,IDO,2 IC = IDP2-I DO 105 K=1,L1 TI5 = CC(I,3,K)+CC(IC,2,K) TI2 = CC(I,3,K)-CC(IC,2,K) TI4 = CC(I,5,K)+CC(IC,4,K) TI3 = CC(I,5,K)-CC(IC,4,K) TR5 = CC(I-1,3,K)-CC(IC-1,2,K) TR2 = CC(I-1,3,K)+CC(IC-1,2,K) TR4 = CC(I-1,5,K)-CC(IC-1,4,K) TR3 = CC(I-1,5,K)+CC(IC-1,4,K) CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3 CH(I,K,1) = CC(I,1,K)+TI2+TI3 CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3 CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3 CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3 CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3 CR5 = TI11*TR5+TI12*TR4 CI5 = TI11*TI5+TI12*TI4 CR4 = TI12*TR5-TI11*TR4 CI4 = TI12*TI5-TI11*TI4 DR3 = CR3-CI4 DR4 = CR3+CI4 DI3 = CI3+CR4 DI4 = CI3-CR4 DR5 = CR2+CI5 DR2 = CR2-CI5 DI5 = CI2-CR5 DI2 = CI2+CR5 CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2 CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2 CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3 CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3 CH(I-1,K,4) = WA3(I-2)*DR4-WA3(I-1)*DI4 CH(I,K,4) = WA3(I-2)*DI4+WA3(I-1)*DR4 CH(I-1,K,5) = WA4(I-2)*DR5-WA4(I-1)*DI5 CH(I,K,5) = WA4(I-2)*DI5+WA4(I-1)*DR5 105 CONTINUE 106 CONTINUE RETURN END SUBROUTINE RADBG (IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) , 1 C1(IDO,L1,IP) ,C2(IDL1,IP), 2 CH2(IDL1,IP) ,WA(*) DATA TPI/6.28318530717959/ ARG = TPI/FLOAT(IP) DCP = COS(ARG) DSP = SIN(ARG) IDP2 = IDO+2 NBD = (IDO-1)/2 IPP2 = IP+2 IPPH = (IP+1)/2 IF (IDO .LT. L1) GO TO 103 DO 102 K=1,L1 DO 101 I=1,IDO CH(I,K,1) = CC(I,1,K) 101 CONTINUE 102 CONTINUE GO TO 106 103 DO 105 I=1,IDO DO 104 K=1,L1 CH(I,K,1) = CC(I,1,K) 104 CONTINUE 105 CONTINUE 106 DO 108 J=2,IPPH JC = IPP2-J J2 = J+J DO 107 K=1,L1 CH(1,K,J) = CC(IDO,J2-2,K)+CC(IDO,J2-2,K) CH(1,K,JC) = CC(1,J2-1,K)+CC(1,J2-1,K) 107 CONTINUE 108 CONTINUE IF (IDO .EQ. 1) GO TO 116 IF (NBD .LT. L1) GO TO 112 DO 111 J=2,IPPH JC = IPP2-J DO 110 K=1,L1 DO 109 I=3,IDO,2 IC = IDP2-I CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K) CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K) CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K) CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K) 109 CONTINUE 110 CONTINUE 111 CONTINUE GO TO 116 112 DO 115 J=2,IPPH JC = IPP2-J DO 114 I=3,IDO,2 IC = IDP2-I DO 113 K=1,L1 CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K) CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K) CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K) CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K) 113 CONTINUE 114 CONTINUE 115 CONTINUE 116 AR1 = 1. AI1 = 0. DO 120 L=2,IPPH LC = IPP2-L AR1H = DCP*AR1-DSP*AI1 AI1 = DCP*AI1+DSP*AR1 AR1 = AR1H DO 117 IK=1,IDL1 C2(IK,L) = CH2(IK,1)+AR1*CH2(IK,2) C2(IK,LC) = AI1*CH2(IK,IP) 117 CONTINUE DC2 = AR1 DS2 = AI1 AR2 = AR1 AI2 = AI1 DO 119 J=3,IPPH JC = IPP2-J AR2H = DC2*AR2-DS2*AI2 AI2 = DC2*AI2+DS2*AR2 AR2 = AR2H DO 118 IK=1,IDL1 C2(IK,L) = C2(IK,L)+AR2*CH2(IK,J) C2(IK,LC) = C2(IK,LC)+AI2*CH2(IK,JC) 118 CONTINUE 119 CONTINUE 120 CONTINUE DO 122 J=2,IPPH DO 121 IK=1,IDL1 CH2(IK,1) = CH2(IK,1)+CH2(IK,J) 121 CONTINUE 122 CONTINUE DO 124 J=2,IPPH JC = IPP2-J DO 123 K=1,L1 CH(1,K,J) = C1(1,K,J)-C1(1,K,JC) CH(1,K,JC) = C1(1,K,J)+C1(1,K,JC) 123 CONTINUE 124 CONTINUE IF (IDO .EQ. 1) GO TO 132 IF (NBD .LT. L1) GO TO 128 DO 127 J=2,IPPH JC = IPP2-J DO 126 K=1,L1 DO 125 I=3,IDO,2 CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC) CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC) CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC) CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC) 125 CONTINUE 126 CONTINUE 127 CONTINUE GO TO 132 128 DO 131 J=2,IPPH JC = IPP2-J DO 130 I=3,IDO,2 DO 129 K=1,L1 CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC) CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC) CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC) CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC) 129 CONTINUE 130 CONTINUE 131 CONTINUE 132 CONTINUE IF (IDO .EQ. 1) RETURN DO 133 IK=1,IDL1 C2(IK,1) = CH2(IK,1) 133 CONTINUE DO 135 J=2,IP DO 134 K=1,L1 C1(1,K,J) = CH(1,K,J) 134 CONTINUE 135 CONTINUE IF (NBD .GT. L1) GO TO 139 IS = -IDO DO 138 J=2,IP IS = IS+IDO IDIJ = IS DO 137 I=3,IDO,2 IDIJ = IDIJ+2 DO 136 K=1,L1 C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) 136 CONTINUE 137 CONTINUE 138 CONTINUE GO TO 143 139 IS = -IDO DO 142 J=2,IP IS = IS+IDO DO 141 K=1,L1 IDIJ = IS DO 140 I=3,IDO,2 IDIJ = IDIJ+2 C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J) C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J) 140 CONTINUE 141 CONTINUE 142 CONTINUE 143 RETURN END C ****************************************************************** C C SUBROUTINE RFFTF(N,R,WSAVE) C C ****************************************************************** C C SUBROUTINE RFFTF COMPUTES THE FOURIER COEFFICIENTS OF A REAL C PERODIC SEQUENCE (FOURIER ANALYSIS). THE TRANSFORM IS DEFINED C BELOW AT OUTPUT PARAMETER R. C C INPUT PARAMETERS C C N THE LENGTH OF THE ARRAY R TO BE TRANSFORMED. THE METHOD C IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES. C N MAY CHANGE SO LONG AS DIFFERENT WORK ARRAYS ARE PROVIDED C C R A REAL ARRAY OF LENGTH N WHICH CONTAINS THE SEQUENCE C TO BE TRANSFORMED C C WSAVE A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 2*N+15. C IN THE PROGRAM THAT CALLS RFFTF. THE WSAVE ARRAY MUST BE C INITIALIZED BY CALLING SUBROUTINE RFFTI(N,WSAVE) AND A C DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT C VALUE OF N. THIS INITIALIZATION DOES NOT HAVE TO BE C REPEATED SO LONG AS N REMAINS UNCHANGED THUS SUBSEQUENT C TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST. C THE SAME WSAVE ARRAY CAN BE USED BY RFFTF AND RFFTB. C C C OUTPUT PARAMETERS C C R R(1) = THE SUM FROM I=1 TO I=N OF R(I) C C IF N IS EVEN SET L =N/2 , IF N IS ODD SET L = (N+1)/2 C C THEN FOR K = 2,...,L C C R(2*K-2) = THE SUM FROM I = 1 TO I = N OF C C R(I)*COS((K-1)*(I-1)*2*PI/N) C C R(2*K-1) = THE SUM FROM I = 1 TO I = N OF C C -R(I)*SIN((K-1)*(I-1)*2*PI/N) C C IF N IS EVEN C C R(N) = THE SUM FROM I = 1 TO I = N OF C C (-1)**(I-1)*R(I) C C ***** NOTE C THIS TRANSFORM IS UNNORMALIZED SINCE A CALL OF RFFTF C FOLLOWED BY A CALL OF RFFTB WILL MULTIPLY THE INPUT C SEQUENCE BY N. C C WSAVE CONTAINS RESULTS WHICH MUST NOT BE DESTROYED BETWEEN C CALLS OF RFFTF OR RFFTB. C C SUBROUTINE RFFTF (N,R,WSAVE) DIMENSION R(*) ,WSAVE(*) IF (N .EQ. 1) RETURN CALL RFFTF1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1)) RETURN END SUBROUTINE RFFTF1 (N,C,CH,WA,IFAC) REAL C(*), CH(*), WA(*), IFAC(*) 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 RADF4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) GO TO 110 101 CALL RADF4 (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 RADF2 (IDO,L1,C,CH,WA(IW)) GO TO 110 103 CALL RADF2 (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 RADF3 (IDO,L1,C,CH,WA(IW),WA(IX2)) GO TO 110 105 CALL RADF3 (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 RADF5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) GO TO 110 107 CALL RADF5 (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 RADFG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) NA = 1 GO TO 110 109 CALL RADFG (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 RADF2 (IDO,L1,CC,CH,WA1) DIMENSION CH(IDO,2,L1) ,CC(IDO,L1,*) , 1 WA1(*) 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 IF((IDO-1)/2.LT.L1) GO TO 108 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 GO TO 111 108 DO 110 I=3,IDO,2 IC = IDP2-I DO 109 K=1,L1 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 109 CONTINUE 110 CONTINUE 111 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 RADF3 (IDO,L1,CC,CH,WA1,WA2) DIMENSION CH(IDO,3,L1) ,CC(IDO,L1,*) , 1 WA1(*) ,WA2(*) DATA TAUR,TAUI /-.5,.866025403784439/ 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 IF((IDO-1)/2.LT.L1) GO TO 104 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 104 DO 106 I=3,IDO,2 IC = IDP2-I DO 105 K=1,L1 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 105 CONTINUE 106 CONTINUE RETURN END SUBROUTINE RADF4 (IDO,L1,CC,CH,WA1,WA2,WA3) DIMENSION CC(IDO,L1,*) ,CH(IDO,4,L1) , 1 WA1(*) ,WA2(*) ,WA3(*) DATA HSQT2 /.7071067811865475/ 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 IF((IDO-1)/2.LT.L1) GO TO 111 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 GO TO 110 111 DO 109 I=3,IDO,2 IC = IDP2-I DO 108 K=1,L1 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 108 CONTINUE 109 CONTINUE 110 IF (MOD(IDO,2) .EQ. 1) RETURN 105 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 RADF5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) DIMENSION CC(IDO,L1,*) ,CH(IDO,5,L1) , 1 WA1(*) ,WA2(*) ,WA3(*) ,WA4(*) DATA TR11,TI11,TR12,TI12 /.309016994374947,.951056516295154, 1-.809016994374947,.587785252292473/ 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 IF((IDO-1)/2.LT.L1) GO TO 104 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 104 DO 106 I=3,IDO,2 IC = IDP2-I DO 105 K=1,L1 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 105 CONTINUE 106 CONTINUE RETURN END SUBROUTINE RADFG (IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) , 1 C1(IDO,L1,IP) ,C2(IDL1,IP), 2 CH2(IDL1,IP) ,WA(*) DATA TPI/6.28318530717959/ ARG = TPI/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. AI1 = 0. 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 SUBROUTINE CHEBY (A, B, F, G, PHI, EPS, ITNO, MXITER, L, M, X P, Q, ERROR, IERR, W) C ****************************************************************** C RATIONAL CHEBYCHEV APPROXIMATION OF CONTINUOUS FUNCTIONS C ****************************************************************** DOUBLE PRECISION A, B, F, G, PHI, EPS, ERROR DOUBLE PRECISION P(*), Q(*), W(*) EXTERNAL F, G, PHI C ------------------- IF (L .LT. 0 .OR. M .LT. 0) GO TO 10 LP1 = L + 1 MP1 = M + 1 LPM = L + M N = LPM + 1 NP1 = N + 1 C ------------------- I1 = NP1 + 1 I2 = I1 + NP1 I3 = I2 + NP1*NP1 I4 = I3 + NP1 I5 = I4 + NP1 CALL CHEBY1 (A, B, F, G, PHI, EPS, ITNO, MXITER, L, M, P, Q, 1 ERROR, IERR, LP1, MP1, LPM, N, NP1, W(1), 2 W(I1), W(I2), W(I3), W(I4), W(I5)) RETURN C ------------------------------------------------------------------ C ERROR RETURN C ------------------------------------------------------------------ 10 IERR = 1 RETURN END SUBROUTINE CHEBY1 (A, B, F, G, PHI, EPS, ITNO, MXITER, L, M, 1 P, Q, ERROR, IERR, LP1, MP1, LPM, N, NP1, 2 X, XVAL, C, D, ERR, H) C ------------------------------------------------------------------ DOUBLE PRECISION A, B, F, G, PHI, EPS, ERROR DOUBLE PRECISION P(LP1), Q(MP1), X(NP1), XVAL(NP1), C(NP1,NP1), 1 D(NP1), ERR(NP1), H(NP1) DOUBLE PRECISION B1, C0, DEL, DN, DNP1, EPS0, HALF, H1, 1 OLDERR, ONE, PI, SIGN, SUM, TAU, TEMPL, TEN, TEST, 2 U, XI, XLB, XM1, Y, Y2, Y3, Z, ZERO, ZZ, Z1, Z2, Z3 EXTERNAL F, G, PHI C ------------------- DATA PI/3.14159265358979323846264338328D0/ DATA ZERO/0.D0/, HALF/.5D0/, ONE/1.D0/, TEN/10.D0/ DATA EPS0/1.D-2/, TAU/.015D0/, C0/.0625D0/ C ------------------- ERROR = ZERO IF (EPS .LE. ZERO .OR. EPS .GE. EPS0) GO TO 200 IERR = 0 C ITNO = 1 XLB = ZERO DN = N DNP1 = NP1 C DO 10 I = 1,LP1 10 P(I) = ZERO DO 11 I = 1,MP1 11 Q(I) = ZERO Q(1) = ONE C C COMPUTE INITIAL APPROXIMATIONS OF THE CRITICAL POINTS C X(1) = A X(NP1) = B K = N/2 IF (K .LE. 0) GO TO 30 B1 = HALF*(B - A) XM1 = HALF*(A + B) DO 20 I = 1,K XI = I Z = -B1*DCOS(PI*(XI/DN)) X(I+1) = Z + XM1 II = NP1 - I 20 X(II) = XM1 - Z C C EVALUATE PHI AT THE CRITICAL POINTS C 30 DO 31 I = 1,NP1 31 XVAL(I) = PHI(X(I)) KOUNT = 1 C C SET UP THE LINEAR EQUATIONS C 40 K = L + 2 SIGN = ONE DO 45 I = 1,NP1 SIGN = -SIGN C(I,1) = ONE IF (L .LE. 0) GO TO 42 DO 41 J = 2,LP1 41 C(I,J) = C(I,J-1)*XVAL(I) 42 D(I) = F(X(I)) IF (M .LE. 0) GO TO 44 TEMPL = SIGN*XLB*G(X(I)) - D(I) C(I,K) = XVAL(I)*TEMPL IF (K .GT. LPM) GO TO 44 DO 43 J = K,LPM 43 C(I,J+1) = C(I,J)*XVAL(I) 44 C(I,NP1) = SIGN*G(X(I)) 45 CONTINUE C C SOLVE THE EQUATIONS CX = D AND STORE THE RESULTS IN D C CALL DPSLV (NP1, 1, C, NP1, D, NP1, IERR) IF (IERR .NE. 0) GO TO 220 IF (KOUNT .GT. 1) GO TO 50 C C REDEFINE THE EQUATIONS AND SOLVE C XLB = (D(NP1) + XLB*DN)/DNP1 IF (M .LE. 0) GO TO 61 KOUNT = 2 GO TO 40 C 50 TEST = DABS(XLB - D(NP1)) XLB = (D(NP1) + XLB*DN)/DNP1 KOUNT = KOUNT + 1 IF (KOUNT .LE. 4 .AND. TEST .GT. EPS0*DABS(XLB)) GO TO 40 C C STORE THE RESULTS IN P AND Q C DO 60 I = 2,MP1 LPI = L + I 60 Q(I) = D(LPI) 61 DO 62 I = 1,LP1 62 P(I) = D(I) C C SEARCH FOR NEW CRITICAL POINTS C OLDERR = ERROR ERROR = ZERO Z1 = ZERO U = ONE IF (XLB .LT. ZERO) U = -U C IF (N .GT. 1) GO TO 70 H(1) = TAU*(X(2) - X(1)) H(2) = -H(1) GO TO 72 70 DO 71 I = 2,N 71 H(I) = TAU*(X(I+1) - X(I-1)) H(1) = HALF*H(2) H(NP1) = -HALF*H(N) 72 CONTINUE C DO 92 I = 1,NP1 Y2 = X(I) H1 = H(I) Y3 = Y2 + H1 CALL CERR(Y2, F(Y2), G(Y2), PHI(Y2), DEL, IERR, L, LP1, M, NP1, D) IF (IERR .NE. 0) RETURN Z2 = U*DEL CALL CERR(Y3, F(Y3), G(Y3), PHI(Y3), DEL, IERR, L, LP1, M, NP1, D) IF (IERR .NE. 0) RETURN Z3 = U*DEL IF (Z2 .LT. Z3) GO TO 80 H1 = -H1 Z = Z3 Z3 = Z2 Z2 = Z Y = Y3 Y3 = Y2 Y2 = Y C 80 Y = Y3 + H1 IF (Y .GE. A) GO TO 81 Y = A GO TO 90 81 IF (Y .LE. B) GO TO 82 Y = B GO TO 90 82 CALL CERR(Y, F(Y), G(Y), PHI(Y), DEL, IERR, L, LP1, M, NP1, D) IF (IERR .NE. 0) RETURN Z = U*DEL IF (Z .LE. Z3) GO TO 83 Y2 = Y3 Y3 = Y Z2 = Z3 Z3 = Z GO TO 80 83 Y = (Z - Z3) + (Z2 - Z3) IF (Y .NE. ZERO) GO TO 84 Y = Y3 GO TO 90 84 Y = HALF*(Y2 + Y3) + H1*(Z2 - Z3)/Y C 90 X(I) = Y CALL CERR(Y, F(Y), G(Y), PHI(Y), DEL, IERR, L, LP1, M, NP1, D) IF (IERR .NE. 0) RETURN ERR(I) = DEL U = -U IF (I .EQ. 1) GO TO 91 IF (X(I) .LE. X(I-1)) GO TO 230 91 Z = DABS(ERR(I)) ERROR = DMAX1(ERROR, Z) IF (Z .GE. TEN) GO TO 240 Y = DABS(XLB) ZZ = ONE IF (Y .NE. ZERO) ZZ = DABS(Z - Y)/Y IF (Z1 .LT. ZZ) Z1 = ZZ 92 CONTINUE C C SEARCH FOR AN EXTRA EXTREMAL POINT BETWEEN THE ENDPOINTS C OF THE INTERVAL AND THE CRITICAL POINTS C IF (X(1) .LE. A) GO TO 110 H1 = C0*(X(1) - A) U = ONE IF (XLB .GE. ZERO) U = -U Z3 = ZERO Y = A DO 100 I = 1,16 CALL CERR(Y, F(Y), G(Y), PHI(Y), DEL, IERR, L, LP1, M, NP1, D) IF (IERR .NE. 0) RETURN Z = U*DEL IF (Z .LE. Z3) GO TO 100 Z3 = Z Z2 = Y 100 Y = Y + H1 ERROR = DMAX1(ERROR, Z3) Z = DABS(XLB) IF (Z3 .LE. Z) GO TO 110 I = NP1 DO 101 II = 2,NP1 ERR(I) = ERR(I-1) X(I) = X(I-1) 101 I = I - 1 X(1) = Z2 ERR(1) = U*Z3 GO TO 113 C 110 IF (X(NP1) .GE. B) GO TO 120 H1 = C0*(B - X(NP1)) U = ONE IF (ERR(NP1) .GE. ZERO) U = -U Z3 = ZERO Y = B DO 111 I = 1,16 CALL CERR(Y, F(Y), G(Y), PHI(Y), DEL, IERR, L, LP1, M, NP1, D) IF (IERR .NE. 0) RETURN Z = U*DEL IF (Z .LE. Z3) GO TO 111 Z3 = Z Z2 = Y 111 Y = Y - H1 ERROR = DMAX1(ERROR, Z3) Z = DABS(XLB) IF (Z3 .LE. Z) GO TO 120 DO 112 I = 1,N ERR(I) = ERR(I+1) 112 X(I) = X(I+1) X(NP1) = Z2 ERR(NP1) = U*Z3 113 XLB = -XLB ZZ = ONE IF (Z .NE. ZERO) ZZ = DABS(Z3 - Z)/Z IF (Z1 .LT. ZZ) Z1 = ZZ C C CHECK FOR CONVERGENCE C 120 IF (Z1 .LE. EPS) RETURN C C SET UP FOR THE NEXT ITERATION C IF (ITNO .GE. MXITER) GO TO 210 SUM = ZERO SIGN = ONE DO 130 I = 1,NP1 SUM = SUM + SIGN*ERR(I) 130 SIGN = -SIGN XLB = SUM/DNP1 ITNO = ITNO + 1 GO TO 30 C ------------------------------------------------------------------ C ERROR RETURN C ------------------------------------------------------------------ C INPUT ERROR C 200 IERR = 1 RETURN C C MXITER ITERATIONS WERE PERFORMED - MORE ITERATIONS ARE NEEDED C 210 IERR = 2 RETURN C C THE LINEAR EQUATIONS CANNOT BE SOLVED C 220 IF (ITNO .EQ. 1) GO TO 250 IERR = 3 RETURN C C THE SEQUENCE OF CRITICAL POINTS IS NOT MONOTONICALLY INCREASING C 230 IERR = 4 IF (I .LE. N) ERROR = OLDERR RETURN C C IT APPEARS THAT THE ALGORITHM HAS FAILED TO CONVERGE C THERE MAY BE POLES IN THE RATIONAL APPROXIMATION C 240 IERR = 5 RETURN C C THE ROUTINE HAS COMPLETELY FAILED - THE RESULTS SHOULD BE IGNORED C 250 IERR = 6 RETURN END SUBROUTINE CERR (T, FT, GT, PHIT, DEL, IERR, L, LP1, M, NP1, D) C ------------------------------------------------------------------ C COMPUTE THE APPROXIMATION ERROR AT POINT T C ------------------------------------------------------------------ DOUBLE PRECISION T, FT, GT, PHIT, DEL, D(NP1) DOUBLE PRECISION P, Q, R, ZERO, ONE DATA ZERO/0.D0/, ONE/1.D0/ C ------------------- P = D(LP1) IF (L .LE. 0) GO TO 20 DO 10 I = 1,L II = LP1 - I 10 P = P*PHIT + D(II) C 20 Q = ZERO IF (M .LE. 0) GO TO 22 DO 21 I = 1,M II = NP1 - I 21 Q = (Q + D(II))*PHIT 22 Q = Q + ONE C IF (Q .EQ. ZERO) GO TO 110 IF (GT .EQ. ZERO) GO TO 100 R = P/Q DEL = (R - FT)/GT RETURN C ------------------------------------------------------------------ C ERROR RETURN C ------------------------------------------------------------------ C THE FUNCTION G IS ZERO AT POINT T C 100 IERR = 1 RETURN C C THE ROUTINE HAS COMPLETELY FAILED - THE RESULTS SHOULD BE IGNORED C 110 IERR = 6 RETURN END SUBROUTINE ADAPT (F, XLFT, XRGT, EPSLN, NPIECE, ERREST, XKNOTS, * COEFS, IERR, KMAX, NDEG, NSMTH, ANORM, DX, MO, KBREAK, BRAKPT, * KDIFF, VALLFT, VALRGT) C C =============================================================== C C TABULATION OF THE INTERNAL AND EXTERNAL NAMES OF THE ARGUMENTS. C C C INTERNAL EXTERNAL C F F C A XLFT C B XRGT C ACCUR EPSLN C KNOTS NPIECE C ERROR ERREST C XKNOTS XKNOTS C COEFS COEFS C IERR IERR C KMAX KMAX C DEGREE NDEG C SMOOTH NSMTH C NORM ANORM C CHARF DX C EDIST MO C NBREAK KBREAK C XBREAK BRAKPT C DBREAK KDIFF C BLEFT VALLFT C BRIGHT VALRGT C DOUBLE PRECISION A, ACCUR, B, BLEFT, BRIGHT, CHARF, DDTEMP, * DSCTOL, ERROR, ERRORI, FACTOR, FINTRP, FLEFT, FRIGHT, NORM, * XBREAK, XDD, XINTRP, XLEFT, XRIGHT, BUFFER DIMENSION XBREAK(20), DBREAK(20), BLEFT(20), BRIGHT(20) DIMENSION XLEFT(50), XRIGHT(50) DIMENSION DDTEMP(20,20), FACTOR(20), FINTRP(18), FLEFT(10), * FRIGHT(10), XDD(20), XINTRP(18) INTEGER BOTH, BREAK, DBREAK, DEGREE, EDIST, RIGHT, RIGHTX, SMOOTH LOGICAL DISCRD DOUBLE PRECISION XKNOTS(*), COEFS(KMAX,*) DOUBLE PRECISION ANORM, BRAKPT, DX, EPSLN, ERREST, VALLFT, * VALRGT, XLFT, XRGT DIMENSION BRAKPT(KBREAK), KDIFF(KBREAK), VALLFT(KBREAK), * VALRGT(KBREAK) DOUBLE PRECISION F EXTERNAL F C COMMON /INPUTZ/ A, B, ACCUR, NORM, CHARF, XBREAK, BLEFT, BRIGHT, * DBREAK, DEGREE, SMOOTH, LEVEL, EDIST, NBREAK, KNTDIM, NPARDM COMMON /RESULZ/ ERROR, KNOTS COMMON /KONTRL/ DSCTOL, ERRORI, XLEFT, XRIGHT, BREAK, BOTH, * FACTOR, IBREAK, INTERP, LEFT, MAXAUX, MAXKNT, MAXPAR, MAXSTK, * NPAR, NSTACK, RIGHT, DISCRD, BUFFER COMMON /COMDIF/ DDTEMP, FINTRP, FLEFT, FRIGHT, XDD, XINTRP, * LEFTX, NINTRP, RIGHTX C C 10 A = XLFT B = XRGT ACCUR = EPSLN DEGREE = NDEG SMOOTH = NSMTH NORM = ANORM CHARF = DX EDIST = MO NBREAK = KBREAK IF (NBREAK.LE.0 .OR. NBREAK.GE.21) GO TO 30 DO 20 K=1,NBREAK XBREAK(K) = BRAKPT(K) DBREAK(K) = KDIFF(K) BLEFT(K) = VALLFT(K) BRIGHT(K) = VALRGT(K) 20 CONTINUE 30 CONTINUE C KDIMEN = KMAX+1 NDIMEN = NDEG+1 CALL ADAPT1(F, XKNOTS, COEFS, KDIMEN, KMAX, NDIMEN, IERR) NPIECE = KNOTS ERREST = ERROR RETURN END SUBROUTINE ADAPT1(F, XKNOTS, COEFS, KDIMEN, KMAX, NDIMEN, IERR) C C THIS ALGORITHM COMPUTES A PIECEWISE POLYNOMIAL APPROXIMATION C OF SPECIFIED SMOOTHNESS, ACCURACY AND DEGREE. THE INPUT TO THE C COMPUTATION IS C C F - FUNCTION BEING APPROXIMATED. IT MUST PROVIDE VALUES OF C DERIVATIVES UP TO THE ORDER OF SMOOTHNESS SPECIFIED FOR C THE APPROXIMATION. THE CALLING SEQUENCE IS F(X,FDERV) AND C FDERV CONTAINS THE DERIVATIVES( SEE CONSTRAINT BELOW) C A,B - THE ENDPOINTS OF THE INTERVAL OF APPROXIMATION C ACCUR - THE ACCURACY REQUIRED FOR THE APPROXIMATION C SMOOTH - THE SMOOTHNESS REQUIRED FOR THE APPROXIMATION C = 0 MEANS CONTINUOUS C = 1 MEANS CONTINUOUS SLOPE C = 2 MEANS CONTINUOUS SECOND DERIVATIVE, ETC. C DEGREE - THE DEGREE OF THE POLYNOMIAL PIECES. C MUST HAVE DEGREE GT 2*SMOOTH C CHARF - CHARACTERISTIC LENGTH OF THE FUNCTION F(X). PIECES ARE NOT C LONGER THAN THIS LENGTH. C NORM - NORM TO MEASURE THE APPROXIMATION ERROR C = 1 L1 APPROXIMATION (LEAST DEVIATIONS) C = 2 L2 APPROXIMATION (LEAST SQUARES) C = 3 TCHEBYCHEFF (MINIMAX) APPROXIMATION C =-P (NEGATIVE VALUE) GENERAL LP APPROXIMATION C NBREAK - NUMBER OF SPECIAL BREAK POINTS IN THE APPROXIMATION. C ASSOCIATED INPUT VARIABLES ARE C XBREAK(J) - LOCATION OF BREAK POINTS C DBREAK(J) - DERIVATIVE BROKEN AT XBREAK C BLEFT (J) - VALUE FROM LEFT FOR DBREAK DERIVATIVE C BRIGHT(J) - - - RIGHT - - - C EDIST - SWITCH TO CHANGE FROM PROPORTIONAL ERROR DISTRIBUTION C TO FIXED DISTRIBUTION. THIS IS PRIMARILY OF USE IN C APPROXIMATION OF FUNCTIONS WITH SINGULARITIES. ONE SHOULD C USE NORM = 1. OR SO IN SUCH CASES C = 0 PROPORTIONAL DISTRIBUTION C = 1 APPROXIMATE FIXED ERROR DISTRIBUTION C ATTEMPTS TO ACHIEVE SPECIFIED ACCURACY VALUE ACCUR C = 2 TRUE FIXED ERROR DISTRIBUTION C C ********** OUTPUT ********** C THE OUTPUT OF THE COMPUTATION CONSISTS OF 4 PARTS, EACH RETURNED C TO THE USER IN A DIFFERENT WAY. THEY ARE C C XKNOTS,COEFS - ARRAYS DEFINING THE PIECEWISE POLYNOMIAL RESULT. C XKNOTS(K) = KNOTS OF THE APPROXIMATION ( K = 1 TO KNOTS) C THE LAST ONE IS RIGHT END POINT OF INTERVAL C COEFS(K,N) = COEFFICIENT OF (X - XKNOT(K))**(N-1) IN THE C INTERVAL XKNOT(K) TO XKNOT(K+1) C K = 1 TO KNOTS-1 AND N = 1 TO DEGREE+1 C THESE ARRAYS ARE PASSED AS ARGUMENTS SO AS TO USE VARIABLE C DIMENSIONS. THE ARRAYS ARE OF DIMENSION XKNOTS(KDIMEN) AND C COEFS(KMAX,NDIMEN). IT IS ASSUMED THAT KDIMEN = KMAX+1. C ***** NOTE ***** SEVERAL SMALL ARRAYS HERE HAVE FIXED C DIMENSIONS THAT LIMIT DEGREE AND THUS NDIMEN C SHOULD NOT EXCEED THIS LIMIT (CURRENTLY = 20) C C RESULZ - A LABELED COMMON BLOCK CONTAINING KNOTS AND ERROR C KNOTS - NUMBER OF KNOTS OF THE APPROXIMATION C ERROR - ESTIMATED ACCURACY OF THE APPROXIMATION C C IERR - STATUS INDICATOR. IERR TAKES THE VALUES C 0 THE APPROXIMATION WAS SUCCESSFULLY CONSTRUCTED. C -1 INPUT ERROR REPORTED BY ADSET. C -2 A AND B ARE TOO CLOSE. C -3 CHARF IS TOO SMALL. C -4 EITHER ALL THE BREAK POINTS ARE NOT BETWEEN A AND B, OR C XBREAK(I).GE.XBREAK(I+1) FOR SOME I. C -5 DBREAK(I).LT.0 .OR. DBREAK(I).GT.(DEGREE-1)/2 FOR SOME I. C 1 THE KNOT LIMIT WAS EXCEEDED. C 2 BREAK POINT ADJUSTMENT REQUIRES THAT A SUBINTERVAL BE C PARTITIONED. HOWEVER, THIS CANNOT BE DONE EITHER BECAUSE C THE INTERVAL STACK IS FULL, OR PARTITIONING WILL PRODUCE C TOO SMALL AN INTERVAL. C 3 A SUBINTERVAL MUST BE PARTITIONED BECAUSE ITS LENGTH IS C GREATER THAN CHARF. HOWEVER, THIS CANNOT BE DONE SINCE THE C INTERVAL STACK IS FULL. C 4 A SUBINTERVAL MUST BE PARTITIONED SO THAT THE ACCURACY C CRITERIA CAN BE SATISFIED. HOWEVER, THIS CANNOT BE DONE C EITHER BECAUSE THE INTERVAL STACK IS FULL, OR PARTITIONING C WILL PRODUCE TOO SMALL AN INTERVAL. C C ********** DIMENSION CONSTRAINTS ********** C MAXKNT - MAX NUMBER OF KNOTS TAKEN FROM USER VIA KDIMEN C ARRAYS WITH THIS DIMENSION (OR RELATED VALUES) C COEFS XKNOTS C MAXPAR - MAX NUMBER OF PARAMETERS PER INTERVAL (CURRENTLY = 20) C USER PROVIDED NDIMEN MUST HAVE NDIMEN LE MAXPAR C MUST HAVE DEGREE + 1 LE MAXPAR C ARRAYS WITH THIS DIMENSION (OR RELATED VALUES) C D DDTEMP FDERVL FDERVR FDUMB FACTOR C FINTRP FLEFT FRIGHT POWERS XTEMP XINTRP XDD C ***** NOTE ***** MAXPAR ALSO AFFECTS ARGUMENT FDERV C OF FUNCTION F. FDERVL, FDERVR ARE ALSO INVOLVED. C SHOULD DECLARE FDERV OF SIZE 10 IN F TO BE SAFE. C MAXAUX - MAXIMUM NUMBER OF AUXILIARY INPUT ( = 20 NOW ). ARRAYS C XBREAK DBREAK BLEFT BRIGHT C MAXSTK - MAX SIZE OF ACTIVE INTERVAL STACK C MIN INTERVAL LENGTH IS 2**(-MAXSTK)*(B-A). ARRAYS C XLEFT XRIGHT C C ********** PORTABILITY CONSIDERATIONS ********** C C ALL THE ROUTINES IN THIS PACKAGE (EXCEPT ADAPT) ARE WRITTEN IN C ANSI STANDARD FORTRAN. IN ADDITION, THEY MEET ALL THE REQUIREMENTS C OF THE BELL LABS PORTABLE FORTRAN -PFORT-. NEVERTHELESS, THE C ROUTINES ARE AFFECTED BY A CHANGE IN MACHINE WORD LENGTH AND C CHANGING TO SINGLE PRECISION. C C ***** THE GAUSS WEIGHTS AND ABSCISSAE IN ADCOMP ARE GIVEN TO C 30 DIGITS. THE PARAMETER EPS0 IN ADSET SPECIFIES THE C ACCURACY OF THESE CONSTANTS. IF THE ACCURACY IS CHANGED C TO K DECIMAL DIGITS THEN SET EPS0 = 10**(-K). C C ***** THE INTERVAL STACK SIZE MAXSTK IS DEFINED IN ADSET TO C BE 50. IF MAXSTK IS MODIFIED THEN SET THE DIMENSIONS OF C XLEFT AND XRIGHT TO THE NEW VALUE FOR MAXSTK. NOTE THAT C THE MINIMUM INTERVAL LENGTH IS 2**(-MAXSTK)*(B-A). C C SINGLE PRECISION CONVERSION -- REQUIRES FOUR STEPS C 1. DECLARE ALL DOUBLE PRECISION VARIABLES TO BE REAL. C C 2. CHANGE ALL DOUBLE PRECISION NUMBERS IN THE DATA STATEMENTS. C (FLOATING POINT NUMBERS APPEAR ONLY IN DATA STATEMENTS.) C C 3. CHANGE DABS,DMAX1,DMIN1 AT MANY PLACES. C C 4. CHANGE DPMPAR TO SPMPAR IN ADSET. C DOUBLE PRECISION A, ACCUR, B, BLEFT, BRIGHT, CHARF, DDTEMP, * DSCTOL, ERROR, ERRORI, FACTOR, FINTRP, FLEFT, FRIGHT, NORM, * XBREAK, XDD, XINTRP, XLEFT, XRIGHT, BUFFER DIMENSION XBREAK(20), DBREAK(20), BLEFT(20), BRIGHT(20) DIMENSION XLEFT(50), XRIGHT(50) DIMENSION DDTEMP(20,20), FACTOR(20), FINTRP(18), FLEFT(10), * FRIGHT(10), XDD(20), XINTRP(18) INTEGER BOTH, BREAK, DBREAK, DEGREE, EDIST, RIGHT, RIGHTX, SMOOTH LOGICAL DISCRD DOUBLE PRECISION XKNOTS(KDIMEN), COEFS(KMAX,NDIMEN) DOUBLE PRECISION F EXTERNAL F C COMMON /INPUTZ/ A, B, ACCUR, NORM, CHARF, XBREAK, BLEFT, BRIGHT, * DBREAK, DEGREE, SMOOTH, LEVEL, EDIST, NBREAK, KNTDIM, NPARDM C KNTDIM - KDIMEN, NAME CHANGED TO PUT IN COMMON C NPARDM - NDIMEN, NAME CHANGED TO PUT IN COMMON COMMON /RESULZ/ ERROR, KNOTS C KNOTS = FINAL NO. OF KNOTS, INCLUDES B AS ONE. C ERROR = ESTIMATE OF ERROR ACTUALLY ACHIEVED. COMMON /KONTRL/ DSCTOL, ERRORI, XLEFT, XRIGHT, BREAK, BOTH, * FACTOR, IBREAK, INTERP, LEFT, MAXAUX, MAXKNT, MAXPAR, MAXSTK, * NPAR, NSTACK, RIGHT, DISCRD, BUFFER C KONTRL CONTAINS GENERALLY USEFUL VARIABLES C MAXSTK - SEE COMMENTS ABOVE C BUFFER - THE MACHINE DEPENDENT TOLERANCE USED C BY THE ALGORITHM C NSTACK - COUNTER FOR INTERVAL STACK, CONSISTS OF C (XLEFT(J),XRIGHT(J)) J = 1 TO NSTACK C ERRORI - ERROR ESTIMATE FOR TOP INTERVAL C DSCTOL - TOLERANCE TO CHECK DISCARDING INTERVALS C DISCRD - SWITCH TO SIGNAL DISCARD OF TOP INTERVAL C FACTOR - ARRAY OF FACTORIALS C NPAR - NUMBER OF PAREMETERS = DEGREE + 1 C INTERP - NUMBER OF INTERIOR INTERPOLATION POINTS C IN THE NORMAL INTERVAL C IBREAK - COUNTER ON BREAK POINTS C BREAK - SWITCH FOR BREAK POINT IN TOP INTERVAL C 0 = NO BREAK PRESENT C LEFT = BREAK AT XLEFT(NSTACK) C RIGHT = BREAK AT XRIGHT(NSTACK) C BOTH = BREAK AT BOTH ENDS COMMON /COMDIF/ DDTEMP, FINTRP, FLEFT, FRIGHT, XDD, XINTRP, * LEFTX, NINTRP, RIGHTX C COMDIF CONTAINS VARIABLES USED ONLY BY ADCOMP AND FRIENDS. C NINTRP - NUMBER OF INTERIOR INTERPOLATION POINTS C FOR THE CURRENT INTERVAL C XINTRP - INTERIOR INTERPOLATION POINTS C FINTRP - F VALUES AT XINTRP POINTS C LEFTX - MULTIPLICITY OF INTERPOLATION AT XLEFT C = NO. OF DERIVATIVES MATCHED AT XLEFT C FLEFT - VALUES OF F AND ITS DERIVATIVES AT XLEFT C RIGHTX - MULTIPLICITY OF INTERPOLATION AT XRIGHT C FRIGHT - VALUES OF F AND DERIVATIVES AT XRIGHT C DDTEMP - THE ARRAY OF DIVIDED DIFFERENCES C XDD - THE X VALUES FOR DDTEMP WITH PROPER C MULTIPLICITIES OF XLEFT AND XRIGHT C C------------------------ MAIN CONTROL PROGRAM ------------------------- C C CHECK THE INPUT AND INITIALIZE ALL THE PARAMETERS C CALL ADSET(XKNOTS, COEFS, KDIMEN, KMAX, NDIMEN, IERR) IF (IERR.NE.0) RETURN C C LOOP OVER PROCESSING OF INTERVALS C 10 CALL ADTAKE(IERR) IF (IERR.NE.0) RETURN CALL ADCOMP(F) C C CHECK FOR DISCARDING INTERVALS C CALL ADCHK C C PUT NEW INTERVALS ON STACK OR DISCARD, UPDATE STATUS C CALL ADPUT(XKNOTS, COEFS, KDIMEN, KMAX, NDIMEN, IERR) IF (IERR.NE.0) RETURN C C TEST FOR NORMAL TERMINATION C IF (NSTACK.EQ.0) RETURN C C CHECK ON THE NUMBER OF KNOTS GENERATED C IF (KNOTS.LT.MAXKNT) GO TO 10 IERR = 1 RETURN END SUBROUTINE ADSET(XKNOTS, COEFS, KDIMEN, KMAX, NDIMEN, IERR) C C =============================================================== C C ** THIS PROGRAM CHECKS THE INPUT DATA AND INITIALIZES THE COMPUTATION C DOUBLE PRECISION A, ACCUR, B, BLEFT, BRIGHT, CHARF, DDTEMP, * DSCTOL, ERROR, ERRORI, FACTOR, FINTRP, FLEFT, FRIGHT, NORM, * XBREAK, XDD, XINTRP, XLEFT, XRIGHT, BUFFER DIMENSION XBREAK(20), DBREAK(20), BLEFT(20), BRIGHT(20) DIMENSION XLEFT(50), XRIGHT(50) DIMENSION DDTEMP(20,20), FACTOR(20), FINTRP(18), FLEFT(10), * FRIGHT(10), XDD(20), XINTRP(18) INTEGER BOTH, BREAK, DBREAK, DEGREE, EDIST, RIGHT, RIGHTX, SMOOTH LOGICAL DISCRD DOUBLE PRECISION XKNOTS(KDIMEN), COEFS(KMAX,NDIMEN) DOUBLE PRECISION AKMAX, EPS, EPS0, KM1, RATIO, ZERO, ONE, TWO, * THREE, C100 DOUBLE PRECISION DPMPAR C COMMON /INPUTZ/ A, B, ACCUR, NORM, CHARF, XBREAK, BLEFT, BRIGHT, * DBREAK, DEGREE, SMOOTH, LEVEL, EDIST, NBREAK, KNTDIM, NPARDM COMMON /RESULZ/ ERROR, KNOTS COMMON /KONTRL/ DSCTOL, ERRORI, XLEFT, XRIGHT, BREAK, BOTH, * FACTOR, IBREAK, INTERP, LEFT, MAXAUX, MAXKNT, MAXPAR, MAXSTK, * NPAR, NSTACK, RIGHT, DISCRD, BUFFER COMMON /COMDIF/ DDTEMP, FINTRP, FLEFT, FRIGHT, XDD, XINTRP, * LEFTX, NINTRP, RIGHTX C DATA EPS0/1.D-30/ DATA ZERO,ONE,TWO,THREE,C100/0.D0,1.D0,2.D0,3.D0,100.D0/ DATA KLEFT, KRIGHT, KBOTH /1, 2, 3/ C EPS = DPMPAR(1) BUFFER = C100*DMAX1(EPS,EPS0) C C PUT DATA STATEMENT ITEMS INTO COMMON VARIABLES C LEFT = KLEFT RIGHT = KRIGHT BOTH = KBOTH C C -------- SET CURRENT VALUES OF LIMITS ON DIMENSIONS ------------------ C KNTDIM = KDIMEN NPARDM = NDIMEN MAXKNT = KNTDIM MAXSTK = 50 MAXPAR = MIN0(20,NPARDM) MAXAUX = 20 C C -------- CHECK INPUT DATA -------------------------------------------- C IERR = 0 IF (A.GE.B .OR. ACCUR.LE.ZERO) GO TO 200 IF (DEGREE.GE.MAXPAR .OR. 2*SMOOTH.GE.DEGREE) GO TO 200 AKMAX = KMAX RATIO = (B-A)/(DABS(A)+DABS(B)) IF (RATIO.LE.TWO*BUFFER*AKMAX) GO TO 210 IF (CHARF.LT.(B-A)/AKMAX) GO TO 220 IF (NORM.GE.ZERO .AND. (NORM-ONE)*(NORM-TWO)*(NORM-THREE).NE.ZERO) * GO TO 200 IF (EDIST*(EDIST-1)*(EDIST-2).NE.0) GO TO 200 IF (NBREAK.LT.0 .OR. NBREAK.GT.MAXAUX) GO TO 200 IF (NBREAK.EQ.0) GO TO 150 C C CHECK THE BREAK POINT DATA, MONOTONICITY AND DEGREE C J = 1 IF (XBREAK(1).LT.A .OR. XBREAK(NBREAK).GT.B) GO TO 230 IF (NBREAK.EQ.1) GO TO 110 DO 100 J=2,NBREAK IF (XBREAK(J-1).GE.XBREAK(J)) GO TO 230 100 CONTINUE 110 LIMSM = (DEGREE-1)/2 DO 120 J=1,NBREAK IF (DBREAK(J).LT.0 .OR. DBREAK(J).GT.LIMSM) GO TO 240 120 CONTINUE C C -------- INITIALIZATION OF VARIABLES --------------------------------- C C ACTIVE INTERVAL STACK C 150 NSTACK = 1 XLEFT(1) = A XRIGHT(1) = B C C TERMINATION AND ERROR VALUES C ERROR = ZERO DSCTOL = ACCUR**DABS(NORM) IF (EDIST.EQ.0) DSCTOL = DSCTOL/(B-A) IF (NORM.EQ.THREE) DSCTOL = ACCUR C C MISCELLANEOUS VARIABLES AND POINTERS C IBREAK = 1 KNOTS = 1 INTERP = DEGREE + 2 - 2*SMOOTH XKNOTS(1) = A NPAR = DEGREE + 1 C C COMPUTE ARRAY OF NPAR FACTORIALS C FACTOR(1) = ONE FACTOR(2) = ONE DO 170 K=3,NPAR KM1 = K-1 FACTOR(K) = KM1*FACTOR(K-1) 170 CONTINUE RETURN C C -------- ERROR RETURN ------------------------------------------------ C 200 IERR = -1 RETURN C C A AND B ARE TOO CLOSE C 210 IERR = -2 RETURN C C CHARF IS TOO SMALL C 220 IERR = -3 RETURN C C BREAK POINTS ARE NOT MONOTONIC C 230 IERR = -4 RETURN C C BAD VALUE IN DERIVATIVE BREAKS C 240 IERR = -5 RETURN END SUBROUTINE ADTAKE(IERR) C C =============================================================== C C ** THIS PROGRAM TAKES AN ACTIVE INTERVAL OFF THE TOP OF THE STACK C IT ALSO DOES MOST OF THE WORK OF LOCATING AND HANDLING C BREAK POINTS C DOUBLE PRECISION A, ACCUR, B, BLEFT, BRIGHT, CHARF, DDTEMP, * DSCTOL, ERROR, ERRORI, FACTOR, FINTRP, FLEFT, FRIGHT, NORM, * XBREAK, XDD, XINTRP, XLEFT, XRIGHT, BUFFER DIMENSION XBREAK(20), DBREAK(20), BLEFT(20), BRIGHT(20) DIMENSION XLEFT(50), XRIGHT(50) DIMENSION DDTEMP(20,20), FACTOR(20), FINTRP(18), FLEFT(10), * FRIGHT(10), XDD(20), XINTRP(18) INTEGER BOTH, BREAK, DBREAK, DEGREE, EDIST, RIGHT, RIGHTX, SMOOTH LOGICAL DISCRD DOUBLE PRECISION DX, RATIO C COMMON /INPUTZ/ A, B, ACCUR, NORM, CHARF, XBREAK, BLEFT, BRIGHT, * DBREAK, DEGREE, SMOOTH, LEVEL, EDIST, NBREAK, KNTDIM, NPARDM COMMON /RESULZ/ ERROR, KNOTS COMMON /KONTRL/ DSCTOL, ERRORI, XLEFT, XRIGHT, BREAK, BOTH, * FACTOR, IBREAK, INTERP, LEFT, MAXAUX, MAXKNT, MAXPAR, MAXSTK, * NPAR, NSTACK, RIGHT, DISCRD, BUFFER COMMON /COMDIF/ DDTEMP, FINTRP, FLEFT, FRIGHT, XDD, XINTRP, * LEFTX, NINTRP, RIGHTX C C CHECK FOR BREAK POINT BREAK = 0 IF (NBREAK.EQ.0 .OR. IBREAK.GT.NBREAK) GO TO 20 IF (XBREAK(IBREAK).GT.XRIGHT(NSTACK)) GO TO 20 C C SET CONTROL VARIABLE BREAK, CHECK FOR LOCATION IF (XBREAK(IBREAK).GT.XLEFT(NSTACK)) GO TO 10 BREAK = LEFT IF (IBREAK.EQ.NBREAK) GO TO 20 C CHECK FOR SECOND BREAK POINT IN THIS INTERVAL IF (XBREAK(IBREAK+1).GE.XRIGHT(NSTACK)) GO TO 20 C NEXT BREAK IS INSIDE INTERVAL, SPLIT TOP INTERVAL BREAK = BOTH C CHECK EXCEEDING STACK LIMIT. IF SO, STOP IF (NSTACK.EQ.MAXSTK) GO TO 30 C DONT SPLIT VERY SMALL INTERVALS, STOP INSTEAD DX = XBREAK(IBREAK+1) - XLEFT(NSTACK) RATIO = DX/(DABS(A)+DABS(B)) IF (RATIO.LE.BUFFER) GO TO 30 NSTACK = NSTACK + 1 XLEFT(NSTACK) = XLEFT(NSTACK-1) XRIGHT(NSTACK) = XBREAK(IBREAK+1) XLEFT(NSTACK-1) = XRIGHT(NSTACK) GO TO 20 C 10 BREAK = RIGHT C CHECK TO SEE IF BREAK IS ALREADY AT RIGHT END POINT IF (XBREAK(IBREAK).GE.XRIGHT(NSTACK)) GO TO 20 C THE BREAK IS INSIDE INTERVAL, SPLIT TOP INTERVAL C CHECK EXCEEDING STACK LIMIT. IF SO, STOP IF (NSTACK.EQ.MAXSTK) GO TO 30 C DONT SPLIT VERY SMALL INTERVALS, STOP INSTEAD DX = XBREAK(IBREAK) - XLEFT(NSTACK) RATIO = DX/(DABS(A)+DABS(B)) IF (RATIO.LE.BUFFER) GO TO 30 NSTACK = NSTACK + 1 XLEFT(NSTACK) = XLEFT(NSTACK-1) XRIGHT(NSTACK) = XBREAK(IBREAK) XLEFT(NSTACK-1) = XRIGHT(NSTACK) 20 CONTINUE RETURN C C A BREAK POINT IS IN THE INTERIOR OF THE TOP SUBINTERVAL OF C THE STACK. THE SUBINTERVAL CANNOT BE PARTITIONED EITHER C BECAUSE THE STACK IS FULL, OR BECAUSE PARTITIONING LEADS TO C TOO SMALL AN INTERVAL. C 30 IERR = 2 RETURN END SUBROUTINE ADCOMP(F) C C =============================================================== C C ** THIS PROGRAM COMPUTES THE PIECEWISE POLYNOMIAL APPROXIMATION ON C THE CURRENT INTERVAL. IT ALSO ESTIMATES THE ERROR C DOUBLE PRECISION A, ACCUR, B, BLEFT, BRIGHT, CHARF, DDTEMP, * DSCTOL, ERROR, ERRORI, FACTOR, FINTRP, FLEFT, FRIGHT, NORM, * XBREAK, XDD, XINTRP, XLEFT, XRIGHT, BUFFER DIMENSION XBREAK(20), DBREAK(20), BLEFT(20), BRIGHT(20) DIMENSION XLEFT(50), XRIGHT(50) DIMENSION DDTEMP(20,20), FACTOR(20), FINTRP(18), FLEFT(10), * FRIGHT(10), XDD(20), XINTRP(18) INTEGER BOTH, BREAK, DBREAK, DEGREE, EDIST, RIGHT, RIGHTX, SMOOTH LOGICAL DISCRD DOUBLE PRECISION ABSC, AJ, DX, FDERVL, FDERVR, FDUMB, R, WGTS DIMENSION ABSC(4), WGTS(4), FDERVL(9), FDERVR(9), FDUMB(9) DOUBLE PRECISION ERRINT, F, POLYDD EXTERNAL F, POLYDD C COMMON /INPUTZ/ A, B, ACCUR, NORM, CHARF, XBREAK, BLEFT, BRIGHT, * DBREAK, DEGREE, SMOOTH, LEVEL, EDIST, NBREAK, KNTDIM, NPARDM COMMON /RESULZ/ ERROR, KNOTS COMMON /KONTRL/ DSCTOL, ERRORI, XLEFT, XRIGHT, BREAK, BOTH, * FACTOR, IBREAK, INTERP, LEFT, MAXAUX, MAXKNT, MAXPAR, MAXSTK, * NPAR, NSTACK, RIGHT, DISCRD, BUFFER COMMON /COMDIF/ DDTEMP, FINTRP, FLEFT, FRIGHT, XDD, XINTRP, * LEFTX, NINTRP, RIGHTX C EQUIVALENCE (FLEFT(2),FDERVL(1)), (FRIGHT(2),FDERVR(1)) DATA R/1.5D0/ C C THIRTY DIGIT VALUES FOR THE GAUSS INTEGRATION CONSTANTS C .861136311594052575223946488893D0 C .339981043584856264802665759103D0 C .347854845137453857373063949222D0 C .652145154862546142626936050778D0 C C ***** THE ABSISSAE AND WEIGHTS ARE GIVEN BELOW TO 30 DIGITS. C THE PARAMETER EPS0 IN ADSET SPECIFIES THE ACCURACY OF C THESE CONSTANTS. IF THE ACCURACY IS CHANGED TO K DECIMAL C DIGITS THEN SET EPS0 = 10**(-K). C DATA ABSC(1) /-.861136311594052575223946488893D0 / DATA ABSC(2) /-.339981043584856264802665759103D0 / DATA ABSC(3) / .339981043584856264802665759103D0 / DATA ABSC(4) / .861136311594052575223946488893D0 / DATA WGTS(1) / .347854845137453857373063949222D0 / DATA WGTS(2) / .652145154862546142626936050778D0 / DATA WGTS(3) / .652145154862546142626936050778D0 / DATA WGTS(4) / .347854845137453857373063949222D0 / C C COMPUTE INTERPOLATION INFORMATION NINTRP = DEGREE - 2*SMOOTH - 1 C C INCREASE NUMBER OF INTERPOLATION POINTS IF BREAK POINTS ARE C SPECIFIED WITH FEWER DERIVATIVES THAN SMOOTH IF (BREAK.EQ.LEFT .OR. BREAK.EQ.RIGHT) NINTRP = NINTRP + SMOOTH - * DBREAK(IBREAK) IF (BREAK.EQ.BOTH) NINTRP = NINTRP + 2*SMOOTH - DBREAK(IBREAK) - * DBREAK(IBREAK+1) IF (NINTRP.EQ.0) GO TO 20 C C GENERATE EQUAL SPACED INTERPOLATION POINTS AJ = NINTRP+1 DX = (XRIGHT(NSTACK)-XLEFT(NSTACK))/AJ DO 10 J=1,NINTRP AJ = J XINTRP(J) = XLEFT(NSTACK) + AJ*DX 10 CONTINUE C C GET LEFT AND RIGHT F-VALUES, PUT F-VALUE IN FIRST ELEMENT C OF ARRAYS FLEFT AND FRIGHT. GET DERIVATIVES BACK AS C OTHER ELEMENTS VIA THE SUBARRAYS FDERVL AND FDERVR. 20 FLEFT(1) = F(XLEFT(NSTACK),FDERVL) FRIGHT(1) = F(XRIGHT(NSTACK),FDERVR) LEFTX = SMOOTH + 1 RIGHTX = LEFTX C GET F-VALUES AT OTHER INTERPOLATION POINTS, IF ANY IF (NINTRP.EQ.0) GO TO 40 DO 30 J=1,NINTRP FINTRP(J) = F(XINTRP(J),FDUMB) 30 CONTINUE C C CHECK FOR BREAK POINTS, MODIFY VALUES IF NECESSARY 40 CONTINUE IF (BREAK.NE.LEFT) GO TO 50 LEFTX = DBREAK(IBREAK) + 1 FLEFT(LEFTX) = BRIGHT(IBREAK) 50 IF (BREAK.NE.RIGHT) GO TO 60 RIGHTX = DBREAK(IBREAK) + 1 FRIGHT(RIGHTX) = BLEFT(IBREAK) 60 IF (BREAK.NE.BOTH) GO TO 70 LEFTX = DBREAK(IBREAK) + 1 RIGHTX = DBREAK(IBREAK+1) + 1 FLEFT(LEFTX) = BRIGHT(IBREAK) FRIGHT(RIGHTX) = BLEFT(IBREAK+1) 70 CONTINUE C C COMPUTE DIVIDED DIFFERENCES, NEWTON FORM OF POLYNOMIAL CALL NEWTON(LEFTX, RIGHTX, NINTRP) C C COMPUTE NORM OF ERROR OF THIS APPROMIMATION USING FOUR PTS C ADD 50 PERCENT FUDGE FACTOR ERRORI = ERRINT(F,POLYDD,XLEFT(NSTACK),XRIGHT(NSTACK),ABSC,WGTS) ERRORI = R*ERRORI RETURN END DOUBLE PRECISION FUNCTION ERRINT(F, FIT, AAA, BBB, POINTS, WEIGHT) C C =============================================================== C C ** THIS FUNCTION DOES A FOUR POINT INTEGRATION RULE FOR THE C ABSOLUTE VALUE OF THE DIFFERENCE OF TWO FUNCTIONS( F AND FIT ) C ABS( F(X) - FIT(X) )**NORM C THE INTEGRATION USES THE POINTS AND WEIGHTS GIVEN AND SCALED C FROM (-1,1) TO (AAA,BBB) C DOUBLE PRECISION A, ACCUR, B, BLEFT, BRIGHT, CHARF, DDTEMP, * DSCTOL, ERROR, ERRORI, FACTOR, FINTRP, FLEFT, FRIGHT, NORM, * XBREAK, XDD, XINTRP, XLEFT, XRIGHT, BUFFER DIMENSION XBREAK(20), DBREAK(20), BLEFT(20), BRIGHT(20) DIMENSION XLEFT(50), XRIGHT(50) DIMENSION DDTEMP(20,20), FACTOR(20), FINTRP(18), FLEFT(10), * FRIGHT(10), XDD(20), XINTRP(18) INTEGER BOTH, BREAK, DBREAK, DEGREE, EDIST, RIGHT, RIGHTX, SMOOTH LOGICAL DISCRD DOUBLE PRECISION AAA, ABMID, BA, BBB, FDUMB, FIT, P, PJ, POINTS, * WEIGHT, ER, F1, F2, TWO, THREE DIMENSION FDUMB(9), POINTS(*), WEIGHT(*) DOUBLE PRECISION F EXTERNAL F, FIT C COMMON /INPUTZ/ A, B, ACCUR, NORM, CHARF, XBREAK, BLEFT, BRIGHT, * DBREAK, DEGREE, SMOOTH, LEVEL, EDIST, NBREAK, KNTDIM, NPARDM COMMON /RESULZ/ ERROR, KNOTS COMMON /KONTRL/ DSCTOL, ERRORI, XLEFT, XRIGHT, BREAK, BOTH, * FACTOR, IBREAK, INTERP, LEFT, MAXAUX, MAXKNT, MAXPAR, MAXSTK, * NPAR, NSTACK, RIGHT, DISCRD, BUFFER COMMON /COMDIF/ DDTEMP, FINTRP, FLEFT, FRIGHT, XDD, XINTRP, * LEFTX, NINTRP, RIGHTX C DATA TWO,THREE/2.0D0,3.0D0/ C C COMPUTE MIDPOINT = ABMID AND HALF LENGTH = BA OF INTERVAL ABMID = (AAA+BBB)/TWO BA = (BBB-AAA)/TWO PJ = ABMID + BA*POINTS(1) C C TEST FOR TCHEBYCHEFF (MINIMAX) NORM WHICH USES SPECIAL CODE IF (NORM.EQ.THREE) GO TO 20 C C HAVE GENERAL LP NORM OR LEAST SQUARES OR LEAST DEVIATIONS P = DABS(NORM) C INITIALIZE THE QUADRATURE RULE ERRINT = DABS(F(PJ,FDUMB)-FIT(PJ))**P*WEIGHT(1) C LOOP THROUGH REMAINING POINTS DO 10 J=2,4 PJ = ABMID + BA*POINTS(J) F1 = F(PJ,FDUMB) F2 = FIT(PJ) ER = DABS(F1-F2)**P ERRINT = ERRINT + DABS(F(PJ,FDUMB)-FIT(PJ))**P*WEIGHT(J) 10 CONTINUE ERRINT = ERRINT*BA GO TO 40 C C TCHEBYCHEFF NORM 20 CONTINUE C FIND MAX ERROR ON POINTS C INITIALIZE ERRINT = DABS(F(PJ,FDUMB)-FIT(PJ)) C LOOP THROUGH THE REMAINING POINTS DO 30 J=2,4 PJ = ABMID + BA*POINTS(J) ERRINT = DMAX1(ERRINT,DABS(F(PJ,FDUMB)-FIT(PJ))) 30 CONTINUE 40 CONTINUE RETURN END SUBROUTINE NEWTON(NL, NR, NI) C C =============================================================== C C ** THIS PROGRAM COMPUTES THE DIVIDED DIFFERENCES ARRAY AS FOLLOWS C NL COALESCED POINTS ON LEFT - DERIV VALUES IN FLEFT C NR COALESCED POINTS ON RIGHT - - - - FRIGHT C NI DISTINCT POINTS INBETWEEN - FNCTN - - FINTRP C C THE POINTS ARE ORDERED XL = XLEFT (NSTACK) C XR = XRIGHT(NSTACK) C XINTRP ARRAY C C LAYOUT OF THE DDTEMP DIVIDED DIFFERENCE ARRAY C C NL=6 LLLLLL****II C NR=4 LLLLL****II L = FIRST TRIANGLE C NI=2 LLLL****II C LLL****II R = SECOND TRIANGLE C LL****II C L****II * = FILL BETWEEN TRIANGLES C RRRRII C RRRII I = COMPLETION FOR INTERPOLATION POINTS C RRII C RII IDIF = HORIZONTAL COORD. = DIFFERENCE ORDER C II IPT = VERTICAL COORD. ASSOCIATED WITH POINTS C I C C DOUBLE PRECISION A, ACCUR, B, BLEFT, BRIGHT, CHARF, DDTEMP, * DSCTOL, ERROR, ERRORI, FACTOR, FINTRP, FLEFT, FRIGHT, NORM, * XBREAK, XDD, XINTRP, XLEFT, XRIGHT, BUFFER DIMENSION XBREAK(20), DBREAK(20), BLEFT(20), BRIGHT(20) DIMENSION XLEFT(50), XRIGHT(50) DIMENSION DDTEMP(20,20), FACTOR(20), FINTRP(18), FLEFT(10), * FRIGHT(10), XDD(20), XINTRP(18) INTEGER BOTH, BREAK, DBREAK, DEGREE, EDIST, RIGHT, RIGHTX, SMOOTH LOGICAL DISCRD DOUBLE PRECISION DIFFF, DIFFX C COMMON /INPUTZ/ A, B, ACCUR, NORM, CHARF, XBREAK, BLEFT, BRIGHT, * DBREAK, DEGREE, SMOOTH, LEVEL, EDIST, NBREAK, KNTDIM, NPARDM COMMON /RESULZ/ ERROR, KNOTS COMMON /KONTRL/ DSCTOL, ERRORI, XLEFT, XRIGHT, BREAK, BOTH, * FACTOR, IBREAK, INTERP, LEFT, MAXAUX, MAXKNT, MAXPAR, MAXSTK, * NPAR, NSTACK, RIGHT, DISCRD, BUFFER COMMON /COMDIF/ DDTEMP, FINTRP, FLEFT, FRIGHT, XDD, XINTRP, * LEFTX, NINTRP, RIGHTX C C MAIN CALCULATION OF DIVIDED DIFFERENCES C DEFINE A FEW SHORT CONSTANTS NL1 = NL - 1 NL2 = NL + 1 NR1 = NR - 1 NR2 = NR + 1 NRL = NR + NL C C PUT X-VALUES IN A SINGLE ARRAY WITH NDDX = NL+NR+NI POINTS DO 10 NDDX=1,NL XDD(NDDX) = XLEFT(NSTACK) 10 CONTINUE NDDX = NL DO 20 K=1,NR NDDX = NDDX + 1 XDD(NDDX) = XRIGHT(NSTACK) 20 CONTINUE C CHECK IF THERE ARE ANY INTERPOLATION POINTS TO ADD TO XDD IF (NI.EQ.0) GO TO 40 DO 30 K=1,NI NDDX = NDDX + 1 XDD(NDDX) = XINTRP(K) 30 CONTINUE C C FILL BORDER OF FIRST TRIANGLE - SIZE NL. 40 CONTINUE C TOP BORDER DO 50 IDIF=1,NL DDTEMP(IDIF,1) = FLEFT(IDIF)/FACTOR(IDIF) 50 CONTINUE IF (NL1.EQ.0) GO TO 70 C BOTTOM BORDER DO 60 IDIF=1,NL1 IPT = NL2 - IDIF DDTEMP(IDIF,IPT) = DDTEMP(IDIF,1) 60 CONTINUE C C FILL BORDER OF SECOND TRIANGLE - SIZE NR 70 CONTINUE C TOP BORDER DO 80 IDIF=1,NR DDTEMP(IDIF,NL2) = FRIGHT(IDIF)/FACTOR(IDIF) 80 CONTINUE IF (NRL.EQ.NL2) GO TO 100 C BOTTOM BORDER DO 90 IDIF=1,NR1 IPT = NRL + 1 - IDIF DDTEMP(IDIF,IPT) = DDTEMP(IDIF,NL2) 90 CONTINUE C C FILL PARALLOGRAM BETWEEN THE TWO TRIANGLES JUST FILLED C FILL ENTRIES PARALLEL TO BOTTOM OF FIRST TRIANGLE 100 CONTINUE C C LOOP STEPPING ALONG TOP SIDE OF SECOND TRIANGLE DO 120 J=2,NR2 IDIF = J C LOOP STEPPING PARALLEL TO BOTTOM SIDE OF FIRST TRIANGLE DO 110 K=2,NL2 IPT = NL + 2 - K DIFFF = DDTEMP(IDIF-1,IPT+1) - DDTEMP(IDIF-1,IPT) IPT2 = IPT - 1 + IDIF DIFFX = XDD(IPT2) - XDD(IPT) DDTEMP(IDIF,IPT) = DIFFF/DIFFX IDIF = IDIF + 1 110 CONTINUE 120 CONTINUE C C FILL IN BOTTOM DIAGONALS FOR INTERPOLATION POINTS, IF ANY IF (NI.EQ.0) GO TO 150 C LOOP THROUGH THE INTERPOLATATION POINTS DO 140 J=1,NI IDIF = 2 NRLJ = NRL + J DDTEMP(1,NRLJ) = FINTRP(J) C LOOP THROUGH THE DIFFERENCES (IDIF INDEX) NRLJ1 = NRLJ - 1 DO 130 K=1,NRLJ1 IPT = NRLJ - K DIFFF = DDTEMP(IDIF-1,IPT+1) - DDTEMP(IDIF-1,IPT) DIFFX = XDD(NRLJ) - XDD(IPT) DDTEMP(IDIF,IPT) = DIFFF/DIFFX IDIF = IDIF + 1 130 CONTINUE 140 CONTINUE 150 CONTINUE RETURN END DOUBLE PRECISION FUNCTION POLYDD(X) C C =============================================================== C C ** THIS FUNCTION EVALUATES THE CURRENT POLYNOMIAL PIECE REPRESENTED C BY THE DIVIDED DIFFERENCES DDTEMP ON THE POINT SET XDD. C DOUBLE PRECISION A, ACCUR, B, BLEFT, BRIGHT, CHARF, DDTEMP, * DSCTOL, ERROR, ERRORI, FACTOR, FINTRP, FLEFT, FRIGHT, NORM, * XBREAK, XDD, XINTRP, XLEFT, XRIGHT, BUFFER DIMENSION XBREAK(20), DBREAK(20), BLEFT(20), BRIGHT(20) DIMENSION XLEFT(50), XRIGHT(50) DIMENSION DDTEMP(20,20), FACTOR(20), FINTRP(18), FLEFT(10), * FRIGHT(10), XDD(20), XINTRP(18) INTEGER BOTH, BREAK, DBREAK, DEGREE, EDIST, RIGHT, RIGHTX, SMOOTH LOGICAL DISCRD DOUBLE PRECISION X C COMMON /INPUTZ/ A, B, ACCUR, NORM, CHARF, XBREAK, BLEFT, BRIGHT, * DBREAK, DEGREE, SMOOTH, LEVEL, EDIST, NBREAK, KNTDIM, NPARDM COMMON /RESULZ/ ERROR, KNOTS COMMON /KONTRL/ DSCTOL, ERRORI, XLEFT, XRIGHT, BREAK, BOTH, * FACTOR, IBREAK, INTERP, LEFT, MAXAUX, MAXKNT, MAXPAR, MAXSTK, * NPAR, NSTACK, RIGHT, DISCRD, BUFFER COMMON /COMDIF/ DDTEMP, FINTRP, FLEFT, FRIGHT, XDD, XINTRP, * LEFTX, NINTRP, RIGHTX C POLYDD = DDTEMP(DEGREE+1,1) DO 10 K=1,DEGREE J = DEGREE + 1 - K POLYDD = DDTEMP(J,1) + (X-XDD(J))*POLYDD 10 CONTINUE RETURN END SUBROUTINE ADCHK C C =============================================================== C C ** THIS PROGRAM CHECKS FOR DISCARDING INTERVAL, APPLIES VARIOUS C TESTS ABOUT DISCARDING INVOLVING EDIST AND CHARF. C DOUBLE PRECISION A, ACCUR, B, BLEFT, BRIGHT, CHARF, DDTEMP, * DSCTOL, ERROR, ERRORI, FACTOR, FINTRP, FLEFT, FRIGHT, NORM, * XBREAK, XDD, XINTRP, XLEFT, XRIGHT, BUFFER DIMENSION XBREAK(20), DBREAK(20), BLEFT(20), BRIGHT(20) DIMENSION XLEFT(50), XRIGHT(50) DIMENSION DDTEMP(20,20), FACTOR(20), FINTRP(18), FLEFT(10), * FRIGHT(10), XDD(20), XINTRP(18) INTEGER BOTH, BREAK, DBREAK, DEGREE, EDIST, RIGHT, RIGHTX, SMOOTH LOGICAL DISCRD DOUBLE PRECISION AKNOTS, DTEST, DX, THREE, FIVE C COMMON /INPUTZ/ A, B, ACCUR, NORM, CHARF, XBREAK, BLEFT, BRIGHT, * DBREAK, DEGREE, SMOOTH, LEVEL, EDIST, NBREAK, KNTDIM, NPARDM COMMON /RESULZ/ ERROR, KNOTS COMMON /KONTRL/ DSCTOL, ERRORI, XLEFT, XRIGHT, BREAK, BOTH, * FACTOR, IBREAK, INTERP, LEFT, MAXAUX, MAXKNT, MAXPAR, MAXSTK, * NPAR, NSTACK, RIGHT, DISCRD, BUFFER COMMON /COMDIF/ DDTEMP, FINTRP, FLEFT, FRIGHT, XDD, XINTRP, * LEFTX, NINTRP, RIGHTX C DATA THREE,FIVE/3.0D0,5.0D0/ C DISCRD = .FALSE. DX = XRIGHT(NSTACK) - XLEFT(NSTACK) IF (DX.GT.CHARF) RETURN C C COMPUTE DTEST FOR THE LOCAL ERROR CRITERION C IF (NORM.EQ.THREE) GO TO 30 IF (EDIST-1) 10,20,30 10 DTEST = DX*DSCTOL GO TO 40 C FOR THE APPROXIMATE FIXED ERROR DISTRIBUTION TYPE WE ESTIMATE C THE FINAL NUMBER OF KNOTS BY( LIMITING IT A LITTLE ) C (NSTACK+KNOTS+2)((B-A)/(XRIGHT-A)) 20 AKNOTS = NSTACK+KNOTS+2 DTEST = DSCTOL/(AKNOTS*DMIN1((B-A)/(XRIGHT(NSTACK)-A),FIVE)) GO TO 40 30 DTEST = DSCTOL C C CHECK FOR DISCARD OF INTERVAL C 40 IF (ERRORI.LE.DTEST) DISCRD = .TRUE. RETURN END SUBROUTINE ADPUT(XKNOTS, COEFS, KDIMEN, KMAX, NDIMEN, IERR) C C =============================================================== C ** THIS PROGRAM PUTS INTERVALS ON THE STACK OR DISCARDS THEM. C WHEN AN INTERVAL IS DISCARDED A NEW KNOT IS FOUND. THEN THIS C PROGRAM UPDATES THE ERROR ESTIMATE, THE XKNOT ARRAY, TRANSFORMS C THE POLYNOMIAL TO THE POWER FORM AND PUT THE COEFFICIENTS INTO C THE ARRAY COEFS. IT ALSO CHECKS FOR PASSING BREAK POINTS C DOUBLE PRECISION A, ACCUR, B, BLEFT, BRIGHT, CHARF, DDTEMP, * DSCTOL, ERROR, ERRORI, FACTOR, FINTRP, FLEFT, FRIGHT, NORM, * XBREAK, XDD, XINTRP, XLEFT, XRIGHT, BUFFER DIMENSION XBREAK(20), DBREAK(20), BLEFT(20), BRIGHT(20) DIMENSION XLEFT(50), XRIGHT(50) DIMENSION DDTEMP(20,20), FACTOR(20), FINTRP(18), FLEFT(10), * FRIGHT(10), XDD(20), XINTRP(18) INTEGER BOTH, BREAK, DBREAK, DEGREE, EDIST, RIGHT, RIGHTX, SMOOTH LOGICAL DISCRD DOUBLE PRECISION XKNOTS(KDIMEN), COEFS(KMAX,NDIMEN) DOUBLE PRECISION DX, HALF, ONE, POWERS, P, RATIO, THREE DIMENSION POWERS(20) C COMMON /INPUTZ/ A, B, ACCUR, NORM, CHARF, XBREAK, BLEFT, BRIGHT, * DBREAK, DEGREE, SMOOTH, LEVEL, EDIST, NBREAK, KNTDIM, NPARDM COMMON /RESULZ/ ERROR, KNOTS COMMON /KONTRL/ DSCTOL, ERRORI, XLEFT, XRIGHT, BREAK, BOTH, * FACTOR, IBREAK, INTERP, LEFT, MAXAUX, MAXKNT, MAXPAR, MAXSTK, * NPAR, NSTACK, RIGHT, DISCRD, BUFFER COMMON /COMDIF/ DDTEMP, FINTRP, FLEFT, FRIGHT, XDD, XINTRP, * LEFTX, NINTRP, RIGHTX C DATA HALF,ONE,THREE/.5D0,1.D0,3.D0/ C C CHECK FOR DISCARDING THE INTERVAL IF (DISCRD) GO TO 30 C C SUBDIVIDE INTERVAL AND PLACE ON STACK IF (NSTACK.LT.MAXSTK) GO TO 10 C FATAL ERROR, EXCEEDED ACTIVE STACK SIZE IERR = 4 DX = XRIGHT(NSTACK)-XLEFT(NSTACK) IF (DX.GT.CHARF) IERR = 3 RETURN C 10 DX = (XRIGHT(NSTACK)-XLEFT(NSTACK))*HALF C CHECK FOR SMALL INTERVALS RATIO = DX/(DABS(A)+DABS(B)) IF (RATIO.GT.BUFFER) GO TO 20 IERR = 4 RETURN C 20 NSTACK = NSTACK + 1 XLEFT(NSTACK) = XLEFT(NSTACK-1) XLEFT(NSTACK-1) = XRIGHT(NSTACK-1) - DX XRIGHT(NSTACK) = XLEFT(NSTACK-1) RETURN C C DISCARD INTERVAL, UPDATE GLOBAL ERROR, XKNOTS AND COEFS 30 P = DABS(NORM) IF (NORM.EQ.THREE) ERROR = DMAX1(ERROR,ERRORI) IF (NORM.NE.THREE) ERROR = (ERROR**P+ERRORI)**(ONE/P) C C CHECK FOR PASSING BREAK POINTS IF (BREAK.EQ.LEFT .OR. BREAK.EQ.BOTH) IBREAK = IBREAK + 1 C C TRANSFORM REPRESENTATION OF POLYNOMIAL FROM DIVIDED C DIFFERENCES TO POWERS OF X WITH ORIGIN AT XKNOTS (KNOTS) CALL ADTRAN(DDTEMP, POWERS) C C PUT COEFS INTO THE MAIN ARRAY DO 40 K=1,NPAR COEFS(KNOTS,K) = POWERS(K) 40 CONTINUE C PUT THE NEW KNOTS IN XKNOTS KNOTS = KNOTS + 1 XKNOTS(KNOTS) = XRIGHT(NSTACK) NSTACK = NSTACK - 1 RETURN END SUBROUTINE ADTRAN(D, POWERS) C C =============================================================== C C ** THIS PROGRAM CONVERTS POLYNOMIAL REPRESENTATION FROM DIVIDED C DIFFERENCE TO POWER FORM. THERE ARE COALESCED POINTS ON EACH C END OF THE INTERVAL (XL,XR) = (XLEFT(NSTACK),XRIGHT(NSTACK)). C THE NUMBER COALESCED AT EACH END IS LEFTX AND RIGHTX. C AND THERE ARE NINTRP OTHER PTS XINTRP(K) INBETWEEN THEM. C SEE SUBROUTINE NEWTON FOR MORE DETAILS C DOUBLE PRECISION A, ACCUR, B, BLEFT, BRIGHT, CHARF, DDTEMP, * DSCTOL, ERROR, ERRORI, FACTOR, FINTRP, FLEFT, FRIGHT, NORM, * XBREAK, XDD, XINTRP, XLEFT, XRIGHT, BUFFER DIMENSION XBREAK(20), DBREAK(20), BLEFT(20), BRIGHT(20) DIMENSION XLEFT(50), XRIGHT(50) DIMENSION DDTEMP(20,20), FACTOR(20), FINTRP(18), FLEFT(10), * FRIGHT(10), XDD(20), XINTRP(18) INTEGER BOTH, BREAK, DBREAK, DEGREE, EDIST, RIGHT, RIGHTX, SMOOTH LOGICAL DISCRD DOUBLE PRECISION D, POWERS, SHIFT, XL, XR, XTEMP DIMENSION D(20,*), POWERS(*), XTEMP(20) C COMMON /INPUTZ/ A, B, ACCUR, NORM, CHARF, XBREAK, BLEFT, BRIGHT, * DBREAK, DEGREE, SMOOTH, LEVEL, EDIST, NBREAK, KNTDIM, NPARDM COMMON /RESULZ/ ERROR, KNOTS COMMON /KONTRL/ DSCTOL, ERRORI, XLEFT, XRIGHT, BREAK, BOTH, * FACTOR, IBREAK, INTERP, LEFT, MAXAUX, MAXKNT, MAXPAR, MAXSTK, * NPAR, NSTACK, RIGHT, DISCRD, BUFFER COMMON /COMDIF/ DDTEMP, FINTRP, FLEFT, FRIGHT, XDD, XINTRP, * LEFTX, NINTRP, RIGHTX C C SET SOME SHORT LOCAL VARIABLE NAMES C XL = XLEFT(NSTACK) XR = XRIGHT(NSTACK) NL = LEFTX NR = RIGHTX NI = NINTRP NRL = NR + NL NRI = NR + NI NRI1 = NRI - 1 NRLI = NRL + NI C C STARTING REPRESENTATION IS (ASSUMING XL = 0 ) C C D(1) +D(2)X +D(3)X**2 + --- +D(NL)X**(NL-1) C +(X**NL)*( D(NL+1)(+D(NL+2)(X-XR)**2 + --- +D(NL+NR)*(X-XR)**(NR-1) C *((X-XR)**NR)*(D(NL+NR+1) + D(NL+NR+2)*(X-XINTRP(1)) C +D(NL+NR+3)*(X-XINTRP(1))(X-XINTRP(2)) + ---)) C C STRATEGY IS TO FIRST CONVERT THE PART FROM THE INTERP. PTS. C TO POLY IN (X-XR). THIS POLY THEN HAS ORIGIN SHIFTED TO XL. C C THE CONVERSION OF THE INTERP PART IS DONE EXPLICITLY FOR DEGREE C TWO OR LESS AND DONE BY SYNTHETIC DIVISION FOR HIGHER DEGREES C C D1 + D2(X-X1) +D3(X**2-(X1+X2)X +X1*X2) C C THE RESULTING COEFFICIENTS ARE PUT IN THE ARRAY POWERS C IF (NI.EQ.0) GO TO 100 C C BUILD UP THE POLYNOMIAL FOR THE INTERPOLATION POINTS C C USE SPECIAL FORMULAS FOR NI LESS THAN 3 IF (NI.EQ.1) GO TO 10 IF (NI.EQ.2) GO TO 20 GO TO 30 10 POWERS(1) = D(NRL+1,1) GO TO 80 20 POWERS(1) = D(NRL+1,1) + (XR-XINTRP(1))*D(NRL+2,1) POWERS(2) = D(NRL+2,1) GO TO 80 C C CONVERSION BY REPEATED SYNTHETIC DIVISION 30 NI1 = NI - 1 C INITIALIZE THE POWERS AND XTEMP ARRAYS DO 40 K=1,NI XTEMP(K) = XINTRP(K) NRLK = NRL + K POWERS(K) = D(NRLK,1) 40 CONTINUE C C DO THE REPEATED SYNTHETIC DIVISION TO REPLACE THE XTEMP C = XINTRP POINTS OF THE NEWTON EXPANSION BY THE XR POINTS DO 70 K=1,NI1 C POWERS(NI) IS FIXED AND SET ABOVE DO 50 II=1,NI1 I = NI - II POWERS(I) = POWERS(I) + (XR-XTEMP(I))*POWERS(I+1) 50 CONTINUE C SHIFT THE NEWTON EXPANSION PTS. UP, PUT IN ONE MORE XR DO 60 II=1,NI1 I = NI - II XTEMP(I+1) = XTEMP(I) 60 CONTINUE XTEMP(1) = XR 70 CONTINUE 80 CONTINUE C SHIFT THE COEFFICIENTS TO THE TOP OF THE POWERS ARRAY DO 90 K=1,NI L = NI + 1 - K LTOP = L + NRL POWERS(LTOP) = POWERS(L) 90 CONTINUE C C HAVE THE INTERPOLATION PT. COEFS. IN THE ARRAY POWERS 100 CONTINUE C PUT THE REMAINING DIVIDED DIFFS INTO THE POWERS ARRAY DO 110 J=1,NRL POWERS(J) = D(J,1) 110 CONTINUE C C TRANSFORM THE ORIGIN OF THE POLYNOMIAL FROM XR TO XL C WE USE REPEATED SYNTHETIC DIVISION IF (NRI.EQ.1) GO TO 140 SHIFT = XR - XL KHI = NRI1 C LOOP THROUGH THE COEFFICIENTS DO 130 J=2,NRI C SYNTHETIC DIVISION LOOP DO 120 K=1,KHI KOEF = NRLI - K POWERS(KOEF) = POWERS(KOEF) - SHIFT*POWERS(KOEF+1) 120 CONTINUE KHI = KHI - 1 130 CONTINUE 140 CONTINUE C THE COEFFICIENTS ARE NOW OF THE POWER FORM WITH ORIGIN XL RETURN END SUBROUTINE CPSC (F, Z, N, IC, TOL, R, RS, ERR) C C EVALUATION OF COMPLEX POWER SERIES COEFFICIENTS OR DERIVATIVES. C C *** INPUT PARAMETERS *** C F COMPLEX FUNCTION, OF WHICH THE COEFFICIENTS OR DERIVATIVES C ARE SOUGHT. THIS FUNCTION MUST BE DECLARED EXTERNAL IN THE C CALLING PROGRAM. C Z COMPLEX POINT AROUND WHICH F IS TO BE EXPANDED OR AT WHICH C DERIVATIVES ARE TO BE EVALUATED. C N INTEGER, NUMBER OF COEFFICIENTS OR DERIVATIVES WANTED. C N MUST BE GE 1 AND LE 51. C IC SELECTS BETWEEN POWER SERIES COEFFICIENTS AND DERIVATIVES. C IC .EQ. 0 ROUTINE RETURNS POWER SERIES COEFFICIENTS IN RS. C IC .NE. 0 ROUTINE RETURNS DERIVATIVES IN RS. C TOL ESTIMATED RELATIVE ACCURACY OF F. IT IS ASSUMED THAT TOL C IS NONNEGATIVE. IF TOL = 0 THEN F IS ASSUMED TO BE CORRECT C TO MACHINE ACCURACY. C C *** INPUT AND OUTPUT PARAMETER *** C R INITIAL RADIUS USED IN SEARCH FOR OPTIMAL RADIUS. THE RESULTING C RADIUS IS LEFT IN R. THE PROVIDED GUESS MAY BE IN ERROR WITH AT C MOST A FACTOR OF 3.E4 . C C *** OUTPUT PARAMETERS *** C RS COMPLEX ARRAY RS(N) CONTAINING THE N FIRST C COEFFICIENTS (CORRESPONDING TO THE POWERS 0 TO N-1) OR DERIVA- C TIVES (ORDERS 0 TO N-1). C ERR REAL ARRAY ERR(N) CONTAINING ABSOLUTE ERROR ESTIMATES FOR THE C NUMBERS IN RS. C DIMENSION IP(32),A(64),RS(N),ERR(N),RT(51,3),FV(6), * IW(7),SC(4),RV(3),C(4),FC(3) COMPLEX F,A,V,RS,RT,FV,U,W,T,Z,RV,RQ,S,XK,MULT,CO C C LIST OF THE VARIABLES INITIALIZED IN THE DATA STATEMENT BELOW. C IW 2**( 0 , 1 , 2 , 3 , 4 , 5 , 6 ) . C IP PERMUTATION CONSTANTS FOR THE FFT. C RV CONSTANTS FOR THE LAURENT SERIES TEST. C DATA IW(1),IW(2),IW(3),IW(4),IW(5),IW(6),IW(7)/1,2,4,8,16,32,64/ DATA IP( 1),IP( 2),IP( 3),IP( 4),IP( 5),IP( 6),IP( 7),IP( 8), * IP( 9),IP(10),IP(11),IP(12),IP(13),IP(14),IP(15),IP(16), * IP(17),IP(18),IP(19),IP(20),IP(21),IP(22),IP(23),IP(24), * IP(25),IP(26),IP(27),IP(28),IP(29),IP(30),IP(31),IP(32)/ * 64,32,48,16,56,24,40,8,60,28,44,12,52,20,36,4,62,30,46,14, * 54,22,38,6,58,26,42,10,50,18,34,2/ DATA RV(1)/(-.4,.3)/, RV(2)/(.7,.2)/, RV(3)/(.02,-.06)/ C C STATEMENT FUNCTION FOR MULTIPLICATION OF A COMPLEX NUMBER C BY A REAL NUMBER. C MULT(RE,CO) = CMPLX(RE*REAL(CO),RE*AIMAG(CO)) C C ------------------- C C ****** EPS0 IS A MACHINE DEPENDENT CONSTANT. EPS0 IS THE C SMALLEST NUMBER SUCH THAT 1 + EPS0 .GT. 1. C EPS0 = SPMPAR(1) C C ------------------- C C INITIALIZATION. C EPS = AMAX1(EPS0,TOL) SC(1) = .125 C(1) = EPS**(1./28.) EP6 = C(1)**6 PI = 4.0*ATAN(1.0) FV(1) = (-1.,0.) FV(2) = (0.,-1.) R1 = SQRT(0.5) RA = 1.0/R1 FV(3) = CMPLX(R1,-R1) DO 10 I = 2,4 SC(I) = .5*SC(I-1) C(I) = SQRT(C(I-1)) ANG = PI*SC(I-1) 10 FV(I+2) = CMPLX(COS(ANG),-SIN(ANG)) C C START EXECUTION. C IF (N .GT. 51 .OR. N .LT. 1) GO TO 260 L2 = 1 LF = 0 NP = 0 M = 0 NR = -1 C C FIND IF A FFT OVER 8, 16, 32, OR 64 POINTS SHOULD BE USED. C KL = 1 IF (N .GT. 6) KL = 2 IF (N .GT. 12) KL = 3 IF (N .GT. 25) KL = 4 KM = KL + 2 KN = 7 - KM IX = IW(KM + 1) IS = IW(KN) 30 V = CMPLX(R,0.0) C C FUNCTION VALUES OF F ARE STORED READY PERMUTATED FOR THE FFT. C DO 40 I = IS,32,IS IQ = IP(I) V = V*FV(KM) A(IQ) = F(Z + V) 40 A(IQ - 1) = F(Z - V) LN = 2 JN = 1 C C THE LOOP DO 70 ... CONSTITUTES THE FFT. C DO 70 L = 1,KM U = (1.,0.) W = FV(L) DO 60 J = 1,JN DO 50 I = J,IX,LN IT = I + JN T = A(IT)*U A(IT) = A(I) - T 50 A(I) = A(I) + T 60 U = U*W LN = LN + LN 70 JN = JN + JN CX = 0.0 B = 1.0 C C TEST ON HOW FAST THE COEFFICIENTS OBTAINED DECREASE. C DO 80 I = 1,IX CT = CABS(A(I))/B IF (CT .LT. CX) GO TO 80 CX = CT INR = I 80 B = B*C(KL) IF (M .LE. 1) GO TO 100 C C ESTIMATE OF THE ROUNDING ERROR LEVEL FOR THE LAST RADIUS. C ERR(1) = CX*EPS DO 90 I = 2,N 90 ERR(I) = ERR(I-1)/R 100 SF = SC(KL) DO 110 I = 1,IX A(I) = MULT(SF,A(I)) 110 SF = SF/R L1 = L2 L2 = 1 IF (INR .GT. IW(KM)) GO TO 150 IF (LF .EQ. 1) GO TO 140 C C TEST IF THE SERIES IS A TAYLOR OR A LAURENT SERIES. C SR = 0.0 SP = 0.0 DO 130 J = 1,3 RQ = MULT(R,RV(J)) S = A(IX) DO 120 I = 2,IX IA = IX + 1 - I 120 S = S*RQ + A(IA) CP = CABS(S) IF (CP .GT. SP) SP = CP CM = CABS(S - F(Z + RQ)) 130 IF (CM .GT. SR) SR = CM IF (SR .GT. 1.E-3*SP) GO TO 150 LF = 1 140 L2 = -1 C C DETERMINATION OF THE NEXT RADIUS TO BE USED. C 150 IF (NR .GE. 0) GO TO 160 FACT = 2.0 IF (L2 .EQ. 1) FACT = 0.5 L1 = L2 NR = 0 160 IF (L1 .NE. L2) GO TO 180 IF (NR .GT. 0) GO TO 170 NP = NP + 1 IF (NP-15) 190,190,260 170 FACT = 1.0/FACT 180 FACT = 1.0/SQRT(FACT) NR = NR + 1 190 R = R*FACT M = NR - KL - 1 IF (M .LE. 0) GO TO 30 C C THE RESULTS FOR THE LAST THREE RADII ARE STORED. C DO 200 I = 1,N 200 RT(I,M) = A(I) IF (M .EQ. 1) GO TO 220 C C EXTRAPOLATION. C DO 210 I = 1,N XK = RT(I,M-1) - RT(I,M) 210 RT(I,M-1) = RT(I,M) - MULT(FC(M-1),XK) IF (M .EQ. 3) GO TO 230 C C CALCULATION OF THE EXTRAPOLATION CONSTANTS. C 220 FC(M) = 1.5 + SIGN(.5,FACT-1.) IF (M .EQ. 2) FC(M) = FC(M) + RA IF (FACT .GT. 1.0) FC(M) = -FC(M) GO TO 30 230 FC(3) = FC(1)*FC(2)/(FC(1) + FC(2) + 1.0) C C FINAL EXTRAPOLATION AND ERROR ESTIMATE. C DO 240 I = 1,N XK = RT(I,1) - RT(I,2) ERR(I) = ERR(I) + EP6*CABS(XK) 240 RS(I) = RT(I,2) - MULT(FC(3),XK) C C MULTIPLY POWER SERIES COEFFICIENTS AND ERROR ESTIMATE BY FACTORIALS C IF DERIVATIVES WANTED. C IF (IC .EQ. 0) RETURN FAC = 0.0 FACT = 1.0 DO 250 I = 1,N RS(I) = MULT(FACT,RS(I)) ERR(I) = FACT*ERR(I) FAC = FAC + 1.0 250 FACT = FACT*FAC RETURN C C ERROR RETURN. C 260 DO 270 I = 1,N RS(I) = (0.,0.) 270 ERR(I) = 1.E10 RETURN END SUBROUTINE DCPSC (FUN, X, Y, N, IC, TOL, R, RS1, RS2, ERR) DOUBLE PRECISION X, Y, TOL, R, RS1(N), RS2(N), ERR(N) C C EVALUATION OF COMPLEX POWER SERIES COEFFICIENTS OR DERIVATIVES. C C *** INPUT PARAMETERS *** C FUN SUBROUTINE WHICH COMPUTES THE COMPLEX FUNCTION F FOR WHICH C THE COEFFICIENTS OR DERIVATIVES ARE SOUGHT. WE WRITE C CALL FUN(U1,U2,W1,W2) C WHEN W = F(U) IS TO BE COMPUTED FOR THE COMPLEX ARGUMENT U. C HERE U1 AND U2 ARE THE REAL AND IMAGINARY PARTS OF U, AND W1 C AND W2 ARE THE REAL AND IMAGINARY PARTS OF W. U1,U2,W1,W2 C HAVE DOUBLE PRECISION VALUES. THE SUBROUTINE FUN MUST BE C DECLARED IN THE CALLING PROGRAM TO BE OF TYPE EXTERNAL. C X REAL PART OF THE COMPLEX POINT AROUND WHICH F IS TO BE C EXPANDED OR AT WHICH ITS DERIVATIVES ARE TO BE COMPUTED. C Y IMAGINARY PART OF THE COMPLEX POINT AROUND WHICH F IS TO BE C EXPANDED OR AT WHICH ITS DERIVATIVES ARE TO BE COMPUTED. C N INTEGER, NUMBER OF COEFFICIENTS OR DERIVATIVES WANTED. C N MUST BE GE 1 AND LE 51. C IC SELECTS BETWEEN POWER SERIES COEFFICIENTS AND DERIVATIVES. C IC .EQ. 0 ROUTINE RETURNS POWER SERIES COEFFICIENTS IN C RS1 AND RS2. C IC .NE. 0 ROUTINE RETURNS DERIVATIVES IN RS1 AND RS2. C TOL ESTIMATED RELATIVE ACCURACY OF FUN. IT IS ASSUMED THAT TOL C IS NONNEGATIVE. IF TOL = 0 THEN FUN IS ASSUMED TO BE CORRECT C TO MACHINE ACCURACY. C C *** INPUT AND OUTPUT PARAMETER *** C R INITIAL RADIUS USED IN SEARCH FOR OPTIMAL RADIUS. THE RESULTING C RADIUS IS LEFT IN R. THE PROVIDED GUESS MAY BE IN ERROR WITH AT C MOST A FACTOR OF 3.E4 . C C *** OUTPUT PARAMETERS *** C RS1 ARRAY RS1(N) CONTAINING THE REAL PARTS OF THE FIRST N COMPLEX C COEFFICIENTS (CORRESPONDING TO THE POWERS 0 TO N-1) OR DERIVA- C TIVES (ORDERS 0 TO N-1). C RS2 ARRAY RS2(N) CONTAINING THE IMAGINARY PARTS OF THE FIRST N C COEFFICIENTS (CORRESPONDING TO THE POWERS 0 TO N-1) OR DERIVA- C TIVES (ORDERS 0 TO N-1). C ERR REAL ARRAY ERR(N) CONTAINING ABSOLUTE ERROR ESTIMATES FOR THE C COMPLEX NUMBERS WHOSE REAL AND IMAGINARY PARTS ARE IN RS1,RS2. C INTEGER IP(32), IW(7) DOUBLE PRECISION ANG,B,CM,CP,CT,CX,EPS,EPS0,EP6,FAC,FACT,PI, * RA,R1,S,SF,SP,SR,T,U,V,W DOUBLE PRECISION C(4),FC(3),SC(4) DOUBLE PRECISION A1(64),A2(64),FV1(6),FV2(6),RT1(51,3),RT2(51,3), * RV1(3),RV2(3) DOUBLE PRECISION DCPABS, DPMPAR C C LIST OF THE VARIABLES INITIALIZED IN THE DATA STATEMENT BELOW. C IW 2**( 0 , 1 , 2 , 3 , 4 , 5 , 6 ) . C IP PERMUTATION CONSTANTS FOR THE FFT. C RV1 REAL PARTS OF THE CONSTANTS FOR THE LAURENT SERIES TEST. C RV2 IMAGINARY PARTS OF THE CONSTANTS FOR THE LAURENT SERIES TEST. C DATA IW(1),IW(2),IW(3),IW(4),IW(5),IW(6),IW(7)/1,2,4,8,16,32,64/ DATA IP( 1),IP( 2),IP( 3),IP( 4),IP( 5),IP( 6),IP( 7),IP( 8), * IP( 9),IP(10),IP(11),IP(12),IP(13),IP(14),IP(15),IP(16), * IP(17),IP(18),IP(19),IP(20),IP(21),IP(22),IP(23),IP(24), * IP(25),IP(26),IP(27),IP(28),IP(29),IP(30),IP(31),IP(32)/ * 64,32,48,16,56,24,40,8,60,28,44,12,52,20,36,4,62,30,46,14, * 54,22,38,6,58,26,42,10,50,18,34,2/ DATA RV1(1)/-.4D0/, RV2(1)/.3D0/, * RV1(2)/ .7D0/, RV2(2)/.2D0/, * RV1(3)/.02D0/, RV2(3)/-.06D0/ C C ------------------- C C ****** EPS0 IS A MACHINE DEPENDENT CONSTANT. EPS0 IS THE C SMALLEST NUMBER SUCH THAT 1 + EPS0 .GT. 1. C EPS0 = DPMPAR(1) C C ------------------- C C INITIALIZATION. C EPS = DMAX1(EPS0,TOL) SC(1) = .125D0 C(1) = EPS**(1.D0/28.D0) EP6 = C(1)**6 PI = 4.D0*DATAN(1.D0) FV1(1) = -1.D0 FV2(1) = 0.D0 FV1(2) = 0.D0 FV2(2) = -1.D0 R1 = DSQRT(0.5D0) RA = 1.D0/R1 FV1(3) = R1 FV2(3) = -R1 DO 10 I = 2,4 SC(I) = 0.5D0*SC(I-1) C(I) = DSQRT(C(I-1)) ANG = PI*SC(I-1) FV1(I + 2) = DCOS(ANG) 10 FV2(I + 2) = -DSIN(ANG) C C START EXECUTION. C IF (N .GT. 51 .OR. N .LT. 1) GO TO 260 L2 = 1 LF = 0 NP = 0 M = 0 NR = -1 C C FIND IF A FFT OVER 8, 16, 32, OR 64 POINTS SHOULD BE USED. C KL = 1 IF (N .GT. 6) KL = 2 IF (N .GT. 12) KL = 3 IF (N .GT. 25) KL = 4 KM = KL + 2 KN = 7 - KM IX = IW(KM + 1) IS = IW(KN) 30 U = R V = 0.D0 C C FUNCTION VALUES OF F ARE STORED READY PERMUTATED FOR THE FFT. C DO 40 I = IS,32,IS IQ = IP(I) T = U*FV1(KM) - V*FV2(KM) V = U*FV2(KM) + V*FV1(KM) U = T CALL FUN(X + U, Y + V, A1(IQ), A2(IQ)) CALL FUN(X - U, Y - V, A1(IQ-1), A2(IQ-1)) 40 CONTINUE LN = 2 JN = 1 C C THE LOOP DO 70 ... CONSTITUTES THE FFT. C DO 70 L = 1,KM U = 1.0 V = 0.0 DO 60 J = 1,JN DO 50 I = J,IX,LN IT = I + JN S = U*A1(IT) - V*A2(IT) T = U*A2(IT) + V*A1(IT) A1(IT) = A1(I) - S A2(IT) = A2(I) - T A1(I) = A1(I) + S 50 A2(I) = A2(I) + T T = U*FV1(L) - V*FV2(L) V = U*FV2(L) + V*FV1(L) 60 U = T LN = LN + LN 70 JN = JN + JN CX = 0.D0 B = 1.D0 C C TEST ON HOW FAST THE COEFFICIENTS OBTAINED DECREASE. C DO 80 I = 1,IX CT = DCPABS(A1(I),A2(I))/B IF (CT .LT. CX) GO TO 80 CX = CT INR = I 80 B = B*C(KL) IF (M .LE. 1) GO TO 100 C C ESTIMATE OF THE ROUNDING ERROR LEVEL FOR THE LAST RADIUS. C ERR(1) = CX*EPS DO 90 I = 2,N 90 ERR(I) = ERR(I-1)/R C 100 SF = SC(KL) DO 110 I = 1,IX A1(I) = SF*A1(I) A2(I) = SF*A2(I) 110 SF = SF/R L1 = L2 L2 = 1 IF (INR .GT. IW(KM)) GO TO 150 IF (LF .EQ. 1) GO TO 140 C C TEST IF THE SERIES IS A TAYLOR OR A LAURENT SERIES. C SR = 0.D0 SP = 0.D0 DO 130 J = 1,3 S = A1(IX) T = A2(IX) U = R*RV1(J) V = R*RV2(J) DO 120 I = 2,IX IA = IX + 1 - I W = (S*U - T*V) + A1(IA) T = (S*V + T*U) + A2(IA) 120 S = W CP = DCPABS(S,T) IF (CP .GT. SP) SP = CP CALL FUN(X + U, Y + V, U, V) CM = DCPABS(S - U, T - V) 130 IF (CM .GT. SR) SR = CM IF (SR .GT. 1.D-3*SP) GO TO 150 LF = 1 140 L2 = -1 C C DETERMINATION OF THE NEXT RADIUS TO BE USED. C 150 IF (NR .GE. 0) GO TO 160 FACT = 2.D0 IF (L2 .EQ. 1) FACT = 0.5D0 L1 = L2 NR = 0 160 IF (L1 .NE. L2) GO TO 180 IF (NR .GT. 0) GO TO 170 NP = NP + 1 IF (NP-15) 190,190,260 170 FACT = 1.D0/FACT 180 FACT = 1.D0/DSQRT(FACT) NR = NR + 1 190 R = R*FACT M = NR - KL - 1 IF (M .LE. 0) GO TO 30 C C THE RESULTS FOR THE LAST THREE RADII ARE STORED. C DO 200 I = 1,N RT1(I,M) = A1(I) 200 RT2(I,M) = A2(I) IF (M .EQ. 1) GO TO 220 C C EXTRAPOLATION. C MM1 = M - 1 DO 210 I = 1,N U = RT1(I,MM1) - RT1(I,M) V = RT2(I,MM1) - RT2(I,M) RT1(I,MM1) = RT1(I,M) - FC(MM1)*U 210 RT2(I,MM1) = RT2(I,M) - FC(MM1)*V IF (M .EQ. 3) GO TO 230 C C CALCULATION OF THE EXTRAPOLATION CONSTANTS. C 220 FC(M) = 1.5D0 + DSIGN(0.5D0,FACT-1.D0) IF (M .EQ. 2) FC(M) = FC(M) + RA IF (FACT .GT. 1.D0) FC(M) = -FC(M) GO TO 30 230 FC(3) = FC(1)*FC(2)/(FC(1) + FC(2) + 1.D0) C C FINAL EXTRAPOLATION AND ERROR ESTIMATE. C DO 240 I = 1,N U = RT1(I,1) - RT1(I,2) V = RT2(I,1) - RT2(I,2) ERR(I) = ERR(I) + EP6*DCPABS(U,V) RS1(I) = RT1(I,2) - FC(3)*U 240 RS2(I) = RT2(I,2) - FC(3)*V C C MULTIPLY POWER SERIES COEFFICIENTS AND ERROR ESTIMATE BY FACTORIALS C IF DERIVATIVES WANTED. C IF (IC .EQ. 0) RETURN FAC = 0.D0 FACT = 1.D0 DO 250 I = 1,N RS1(I) = FACT*RS1(I) RS2(I) = FACT*RS2(I) ERR(I) = FACT*ERR(I) FAC = FAC + 1.D0 250 FACT = FACT*FAC RETURN C C ERROR RETURN. C 260 DO 270 I = 1,N RS1(I) = 0.D0 RS2(I) = 0.D0 270 ERR(I) = 1.D10 RETURN END FUNCTION TRP(A,N,X,Y) DIMENSION X(N),Y(N) C NM1 = N-1 IF (A.LT.X(2)) GO TO 50 IF (A.GE.X(NM1)) GO TO 40 IL = 2 IR = NM1 C C BISECTION SEARCH C 10 I = (IL+IR)/2 IF (I.EQ.IL) GO TO 60 IF (A-X(I)) 20,60,30 20 IR = I GO TO 10 30 IL = I GO TO 10 C C A.LT.X(2) .OR. A.GE.X(N-1) C 40 I = NM1 GO TO 60 50 I = 1 C C EVALUATION C 60 R = (A-X(I))/(X(I+1)-X(I)) TRP = Y(I)+R*(Y(I+1)-Y(I)) RETURN END SUBROUTINE LTRP (M,X,Y,N,XI,YI,NI,T,IERR) C ****************************************************************** C LAGRANGE INTERPOLATION C ****************************************************************** DIMENSION X(N),Y(N),XI(NI),YI(NI),T(M) C C CHECK INPUT C IF (M.LT.2) GO TO 130 IF (M.GT.N) GO TO 131 IF (NI.LT.1) GO TO 132 IERR = 0 C C INITIALIZATION C MM1 = M-1 K = 1 XX = XI(1) ILOLD = 0 C C FIND THE SUBINTERVAL WHICH CONTAINS XX. I = 1 IF XX.LT.X(2) C AND I = N IF XX.GE.X(N). OTHERWISE X(I).LE.XX.LT.X(I+1). C IF (XX-X(1)) 10,11,20 10 I = 1 IL = 1 IR = M GO TO 80 11 I = 1 YI(K) = Y(1) GO TO 110 C 20 IF (X(N)-XX) 21,22,23 21 I = N IL = N-M+1 IR = N GO TO 80 22 I = N YI(K) = Y(N) GO TO 110 23 IL = 1 IR = N C C BISECTION SEARCH C 30 I = (IL+IR)/2 IF (I.EQ.IL) GO TO 50 IF (XX-X(I)) 31,32,33 31 IR = I GO TO 30 32 YI(K) = Y(I) GO TO 110 33 IL = I GO TO 30 C C LINEAR FORWARD SEARCH C 40 IF (XX-X(I+1)) 50,41,42 41 I = I+1 YI(K) = Y(I) GO TO 110 42 I = I+1 GO TO 40 C C POINT XX LIES IN THE OPEN SUBINTERVAL (X(I),X(I+1)). C FIND THE M CLOSEST POINTS X(IL),...,X(IR) TO XX. C 50 IF (I.GT.M) GO TO 51 IL = 1 NUM = I GO TO 60 51 IL = I-M+1 NUM = M C 60 IPM = I+M IF (IPM.LE.N) GO TO 61 IR = N NUM = NUM+N-I GO TO 70 61 IR = IPM NUM = NUM+M C 70 NUM = NUM-M IF (NUM.EQ.0) GO TO 80 DL = XX-X(IL) DR = X(IR)-XX DO 72 L=1,NUM IF (DL.LE.DR) GO TO 71 IL = IL+1 DL = XX-X(IL) GO TO 72 71 IR = IR-1 DR = X(IR)-XX 72 CONTINUE C C COMPUTE THE COEFFICIENTS T(1),...,T(M) OF THE BACKWARD C NEWTON FORM OF THE INTERPOLATING POLYNOMIAL. C 80 IF (IL.EQ.ILOLD) GO TO 100 ILOLD = IL ILM1 = IL-1 DO 81 J=1,M L = ILM1+J 81 T(J) = Y(L) C DO 91 ISTEP=1,MM1 JMAX = M-ISTEP DO 90 J=1,JMAX II = ILM1+J L = II+ISTEP 90 T(J) = (T(J)-T(J+1))/(X(II)-X(L)) 91 CONTINUE C C EVALUATION OF THE INTERPOLATING POLYNOMIAL C 100 YI(K) = T(1) DO 101 J=2,M L = ILM1+J 101 YI(K) = T(J)+YI(K)*(XX-X(L)) C C NEXT POINT C 110 IF (K.GE.NI) RETURN K = K+1 XX = XI(K) IF (XX-X(1)) 10,11,111 111 IF (X(N)-XX) 21,22,120 C 120 IF (XX-XI(K-1)) 121,122,40 121 IL = 1 IR = MIN0(I+1,N) GO TO 30 122 YI(K) = YI(K-1) GO TO 110 C C ERROR RETURN C 130 IERR = 1 RETURN 131 IERR = 2 RETURN 132 IERR = 3 RETURN END SUBROUTINE HTRP (N,X,Y,A,T,IERR) C ****************************************************************** C HERMITE INTERPOLATION C ****************************************************************** DIMENSION X(N),Y(N),A(N),T(N) IF (N.LE.0) GO TO 30 IERR = 0 A(1) = Y(1) IF (N.EQ.1) RETURN F = 1.0 R = 0.0 IEND = 0 IBEG = 1 C DO 22 K=2,N IF (X(K)-X(K-1)) 10,20,10 C 10 F = 1.0 R = 0.0 IEND = K-1 IBEG = K T(1) = Y(K) DO 11 I=1,IEND DIFF = X(I)-X(K) IF (DIFF) 11,31,11 11 T(I+1) = (A(I)-T(I))/DIFF GO TO 22 C 20 R = R+1.0 F = F*R T(1) = Y(K)/F IF (IEND.EQ.0) GO TO 22 DO 21 I=1,IEND 21 T(I+1) = (T(I+1)-T(I))/(X(I)-X(K)) 22 A(K) = T(IBEG) RETURN C 30 IERR = 1 RETURN 31 IERR = 2 T(1) = I T(2) = K RETURN END SUBROUTINE PCOEFF(ALPHA,N,X,A,C,T) REAL X(*),A(N),C(N) DOUBLE PRECISION XX,R,T(N) IF (N.GT.1) GO TO 10 C(1) = A(1) RETURN C 10 XX = ALPHA NM1 = N-1 DO 11 I=1,N 11 T(I) = A(I) C DO 21 I=1,NM1 J = N-I R = XX-DBLE(X(J)) DO 20 K=J,NM1 20 T(K) = T(K)+R*T(K+1) 21 CONTINUE C DO 30 I=1,N 30 C(I) = T(I) RETURN END SUBROUTINE PFIT(ND,NP,X,Y,A,RNORM,PHI,PHIX,IERR) C ****************************************************************** C UNWEIGHTED LEAST SQUARES POLYNOMIAL FIT C ****************************************************************** REAL X(NP),Y(NP),A(*),PHI(2,*),PHIX(4,NP) REAL LAMBDA DOUBLE PRECISION DALPHA,DSUM C --------------------- IERR=0 IF (1.LE.ND.AND.ND.LT.NP) GO TO 10 IERR=1 RETURN C C INITIALIZATION C 10 ND1=ND+1 DO 11 K=1,ND1 A(K)=0.0 PHI(1,K)=0.0 11 PHI(2,K)=0.0 C C SET Z=A+B*X WHERE ABS(Z).LE.1 C XMIN=X(1) XMAX=X(1) DO 21 K=2,NP IF (X(K).GE.XMIN) GO TO 20 XMIN=X(K) GO TO 21 20 IF (X(K).GT.XMAX) XMAX=X(K) 21 CONTINUE ZB=2.0/(XMAX-XMIN) ZA=-XMIN*ZB-1.0 DO 22 K=1,NP 22 PHIX(3,K)=ZA+ZB*X(K) C C COMPUTE THE CLOSEST POLYNOMIAL OF DEGREE 0 C LAMBDA=NP PHI(1,1)=1.0/SQRT(LAMBDA) DALPHA=0.D0 DSUM=0.D0 DO 30 K=1,NP PHIX(1,K)=PHI(1,1) DALPHA=DALPHA+DBLE(PHIX(3,K)) 30 DSUM=DSUM+DBLE(Y(K)) ALPHA=SNGL(DALPHA)/LAMBDA A(1)=SNGL(DSUM)/LAMBDA DO 31 K=1,NP 31 PHIX(4,K)=A(1) C LA=2 LB=1 DO 90 M=1,ND MP1=M+1 C C GENERATE LAMBDA(M)*PHI(M) AND EVALUATE IT AT Z C IF (M.NE.1) GO TO 50 PHI(2,1)=-ALPHA*PHI(1,1) PHI(2,2)=PHI(1,1) DO 40 K=1,NP 40 PHIX(2,K)=(PHIX(3,K)-ALPHA)*PHI(1,1) GO TO 60 C 50 C=0.0 DO 51 K=1,M PHI(LA,K)=DBLE(C)-DBLE(ALPHA*PHI(LB,K))-DBLE(LAMBDA*PHI(LA,K)) 51 C=PHI(LB,K) PHI(LA,MP1)=C DO 52 K=1,NP 52 PHIX(LA,K)=(PHIX(3,K)-ALPHA)*PHIX(LB,K)-LAMBDA*PHIX(LA,K) C C COMPUTE ALPHA(M) AND LAMBDA(M) C 60 DALPHA=0.D0 DSUM=0.D0 DO 61 K=1,NP C=PHIX(LA,K)*PHIX(LA,K) DALPHA=DALPHA+DBLE(C*PHIX(3,K)) 61 DSUM=DSUM+DBLE(C) LAMBDA=DSUM ALPHA=SNGL(DALPHA)/LAMBDA LAMBDA=SQRT(LAMBDA) C C GENERATE PHI(M) AND EVALUATE IT AT Z C DO 70 K=1,MP1 70 PHI(LA,K)=PHI(LA,K)/LAMBDA DO 71 K=1,NP 71 PHIX(LA,K)=PHIX(LA,K)/LAMBDA C C COMPUTE THE CLOSEST POLYNOMIAL OF DEGREE M OR LESS C AND EVALUATE IT AT Z C DSUM=0.D0 DO 80 K=1,NP 80 DSUM=DSUM+DBLE((Y(K)-PHIX(4,K))*PHIX(LA,K)) C=DSUM DO 81 K=1,MP1 81 A(K)=A(K)+C*PHI(LA,K) DO 82 K=1,NP 82 PHIX(4,K)=PHIX(4,K)+C*PHIX(LA,K) C LS=LA LA=LB 90 LB=LS C C COMPUTE RNORM C DSUM=0.D0 DO 95 K=1,NP 95 DSUM=DSUM+DBLE((Y(K)-PHIX(4,K))**2) RNORM=SQRT(SNGL(DSUM)) C C CONVERT THE CLOSEST POLYNOMIAL FROM A POLYNOMIAL C IN Z TO A POLYNOMIAL IN X C A(1)=A(1)+ZA*A(2) A(2)=ZB*A(2) IF (ND.EQ.1) RETURN PHI(1,1)=ZA PHI(1,2)=ZB DO 102 M=2,ND MP1=M+1 C=0.0 DO 100 K=1,M TEMP=PHI(1,K)*ZB PHI(1,K)=PHI(1,K)*ZA+C 100 C=TEMP PHI(1,MP1)=C DO 101 K=1,M 101 A(K)=A(K)+A(MP1)*PHI(1,K) 102 A(MP1)=A(MP1)*PHI(1,MP1) RETURN END SUBROUTINE WPFIT(ND,NP,X,Y,W,A,RNORM,PHI,PHIX,IERR) C ****************************************************************** C WEIGHTED LEAST SQUARES POLYNOMIAL FIT C ****************************************************************** REAL X(NP),Y(NP),W(NP),A(*),PHI(2,*),PHIX(4,NP) REAL LAMBDA DOUBLE PRECISION DALPHA,DSUM C --------------------- C C ERROR CHECKING C IF (ND.LT.1.OR.NP.LT.2) GO TO 200 NW=0 DSUM=0.D0 DO 13 K=1,NP IF (W(K)) 202,13,10 10 NW=NW+1 DSUM=DSUM+DBLE(W(K)) IF (NW.GT.1) GO TO 11 XMIN=X(K) XMAX=X(K) GO TO 13 11 IF (X(K).GE.XMIN) GO TO 12 XMIN=X(K) GO TO 13 12 IF (X(K).GT.XMAX) XMAX=X(K) 13 CONTINUE IF (ND.GE.NW) GO TO 200 C C INITIALIZATION C IERR=0 ND1=ND+1 DO 20 K=1,ND1 A(K)=0.0 PHI(1,K)=0.0 20 PHI(2,K)=0.0 C C SET Z=A+B*X WHERE ABS(Z).LE.1 C ZB=2.0/(XMAX-XMIN) ZA=-XMIN*ZB-1.0 DO 25 K=1,NP 25 PHIX(3,K)=ZA+ZB*X(K) C C COMPUTE THE CLOSEST POLYNOMIAL OF DEGREE 0 C LAMBDA=DSUM PHI(1,1)=1.0/SQRT(LAMBDA) DALPHA=0.D0 DSUM=0.D0 DO 30 K=1,NP PHIX(1,K)=PHI(1,1) DALPHA=DALPHA+DBLE(W(K)*PHIX(3,K)) 30 DSUM=DSUM+DBLE(W(K)*Y(K)) ALPHA=SNGL(DALPHA)/LAMBDA A(1)=SNGL(DSUM)/LAMBDA DO 31 K=1,NP 31 PHIX(4,K)=A(1) C LA=2 LB=1 DO 90 M=1,ND MP1=M+1 C C GENERATE LAMBDA(M)*PHI(M) AND EVALUATE IT AT Z C IF (M.NE.1) GO TO 50 PHI(2,1)=-ALPHA*PHI(1,1) PHI(2,2)=PHI(1,1) DO 40 K=1,NP 40 PHIX(2,K)=(PHIX(3,K)-ALPHA)*PHI(1,1) GO TO 60 C 50 C=0.0 DO 51 K=1,M PHI(LA,K)=DBLE(C)-DBLE(ALPHA*PHI(LB,K))-DBLE(LAMBDA*PHI(LA,K)) 51 C=PHI(LB,K) PHI(LA,MP1)=C DO 52 K=1,NP 52 PHIX(LA,K)=(PHIX(3,K)-ALPHA)*PHIX(LB,K)-LAMBDA*PHIX(LA,K) C C COMPUTE ALPHA(M) AND LAMBDA(M) C 60 DALPHA=0.D0 DSUM=0.D0 DO 61 K=1,NP C=W(K)*PHIX(LA,K)*PHIX(LA,K) DALPHA=DALPHA+DBLE(C*PHIX(3,K)) 61 DSUM=DSUM+DBLE(C) LAMBDA=DSUM ALPHA=SNGL(DALPHA)/LAMBDA LAMBDA=SQRT(LAMBDA) C C GENERATE PHI(M) AND EVALUATE IT AT Z C DO 70 K=1,MP1 70 PHI(LA,K)=PHI(LA,K)/LAMBDA DO 71 K=1,NP 71 PHIX(LA,K)=PHIX(LA,K)/LAMBDA C C COMPUTE THE CLOSEST POLYNOMIAL OF DEGREE M OR LESS C AND EVALUATE IT AT Z C DSUM=0.D0 DO 80 K=1,NP 80 DSUM=DSUM+DBLE(W(K)*(Y(K)-PHIX(4,K))*PHIX(LA,K)) C=DSUM DO 81 K=1,MP1 81 A(K)=A(K)+C*PHI(LA,K) DO 82 K=1,NP 82 PHIX(4,K)=PHIX(4,K)+C*PHIX(LA,K) C LS=LA LA=LB 90 LB=LS C C COMPUTE RNORM C DSUM=0.D0 DO 95 K=1,NP 95 DSUM=DSUM+DBLE(W(K)*(Y(K)-PHIX(4,K))**2) RNORM=SQRT(SNGL(DSUM)) C C CONVERT THE CLOSEST POLYNOMIAL FROM A POLYNOMIAL C IN Z TO A POLYNOMIAL IN X C A(1)=A(1)+ZA*A(2) A(2)=ZB*A(2) IF (ND.EQ.1) RETURN PHI(1,1)=ZA PHI(1,2)=ZB DO 102 M=2,ND MP1=M+1 C=0.0 DO 100 K=1,M TEMP=PHI(1,K)*ZB PHI(1,K)=PHI(1,K)*ZA+C 100 C=TEMP PHI(1,MP1)=C DO 101 K=1,M 101 A(K)=A(K)+A(MP1)*PHI(1,K) 102 A(MP1)=A(MP1)*PHI(1,MP1) RETURN C C ERROR RETURN C 200 IERR=1 RETURN 202 IERR=3 RETURN END SUBROUTINE CBSPL (X, Y, A, B, C, N, IBEG, IEND, ALPHA, BETA, IERR) C----------------------------------------------------------------------- C CUBIC SPLINE INTERPOLATION C----------------------------------------------------------------------- REAL X(N), Y(N), A(N), B(N), C(N) C IF (N .LT. 3) GO TO 200 C A TRIDIAGONAL LINEAR SYSTEM FOR THE UNKNOWN SLOPES S(I) OF C F AT X(I), I=1,...,N, IS GENERATED AND THEN SOLVED BY GAUSS C ELIMINATION, WITH S(I) ENDING UP IN A(I) FOR ALL I. A, B, C C ARE USED INITIALLY FOR WORK SPACES. C DO 10 M = 2,N B(M) = X(M) - X(M-1) IF (B(M) .LE. 0.0) GO TO 210 C(M) = (Y(M) - Y(M-1))/B(M) 10 CONTINUE IERR = 0 C C CONSTRUCT THE FIRST EQUATION FROM THE BOUNDARY CONDITION, OF C THE FORM C C C(1)*S(1) + B(1)*S(2) = A(1) C IF (IBEG - 1) 20,30,40 C C NO CONDITION AT LEFT END. C 20 C(1) = B(3) B(1) = X(3) - X(1) A(1) = ((B(2) + 2.0*B(1))*B(3)*C(2) + B(2)*B(2)*C(3))/B(1) GO TO 50 C C SLOPE PRESCRIBED AT LEFT END. C 30 C(1) = 1.0 B(1) = 0.0 A(1) = ALPHA GO TO 50 C C SECOND DERIVATIVE PRESCRIBED AT LEFT END. C 40 C(1) = 2.0 B(1) = 1.0 A(1) = 3.0*C(2) - 0.5*ALPHA*B(2) C C FOR THE INTERIOR KNOTS, GENERATE THE CORRESPONDING EQUATIONS AND C CARRY OUT THE FORWARD PASS OF GAUSS ELIMINATION, AFTER WHICH THE C M-TH EQUATION READS C(M)*S(M) + B(M)*S(M+1) = A(M). C 50 NM1 = N - 1 DO 51 M = 2,NM1 T = -B(M+1)/C(M-1) A(M) = T*A(M-1) + 3.0*(B(M)*C(M+1) + B(M+1)*C(M)) C(M) = T*B(M-1) + 2.0*(B(M) + B(M+1)) 51 CONTINUE C C IF THE SLOPE AT THE RIGHT END IS GIVEN, THEN SET A(N) TO THE C SLOPE AND GO TO BACK SUBSTITUTION. OTHERWISE, CONSTRUCT THE C LAST EQUATION FROM THE SECOND BOUNDARY CONDITION, OF THE FORM C C R*S(N-1) + C(N)*S(N) = A(N) C IF (IEND - 1) 60,80,90 60 IF (N .EQ. 3 .AND. IBEG .EQ. 0) GO TO 70 C C NO CONDITION AT THE RIGHT END. EITHER N .GE. 4 OR C THERE IS A CONDITION AT THE LEFT END. C R = X(N) - X(N-2) DEL = (Y(NM1) - Y(N-2))/B(NM1) A(N) = ((B(N) + 2.0*R)*B(NM1)*C(N) + B(N)*B(N)*DEL)/R C(N) = B(NM1) GO TO 100 C C NO CONDITIONS AT THE END POINTS AND N = 3. IN THIS CASE, C THE SECOND BOUNDARY CONDITION DOES NOT PROVIDE US WITH A C NEW EQUATION. FOR CONVENIENCE, WE USE THE FOLLOWING... C 70 A(N) = 2.0*C(N) C(N) = 1.0 R = 1.0 GO TO 100 C C SLOPE PRESCRIBED AT RIGHT END. C 80 A(N) = BETA GO TO 110 C C SECOND DERIVATIVE PRESCRIBED AT RIGHT END. C 90 A(N) = 3.0*C(N) + 0.5*BETA*B(N) C(N) = 2.0 R = 1.0 C C COMPLETE FORWARD PASS OF GAUSS ELIMINATION. C 100 T = -R/C(NM1) A(N) = (T*A(NM1) + A(N))/(T*B(NM1) + C(N)) C C CARRY OUT BACK SUBSTITUTION. C 110 DO 120 I = 1,NM1 J = N - I A(J) = (A(J) - B(J)*A(J+1))/C(J) 120 CONTINUE C C GENERATE THE CUBIC COEFFICIENTS B(I) AND C(I). C DO 130 I = 1,NM1 H = B(I+1) DEL = (Y(I+1) - Y(I))/H T = A(I) + A(I+1) - 2.0*DEL B(I) = (DEL - A(I) - T)/H C(I) = (T/H)/H 130 CONTINUE RETURN C C ERROR RETURN C 200 IERR = 1 RETURN 210 IERR = 2 RETURN END SUBROUTINE SPLIFT (X,Y,YP,YPP,N,W,IERR,ISX,A1,B1,AN,BN) C C WRITTEN BY RONDALL E. JONES C SANDIA LABORATORIES C ALBUQUERQUE, NEW MEXICO 87115 C JANUARY 1976 C C ABSTRACT C SPLIFT FITS AN INTERPOLATING CUBIC SPLINE TO THE N DATA POINTS C GIVEN IN X AND Y AND RETURNS THE FIRST AND SECOND DERIVATIVES C IN YP AND YPP. C C DESCRIPTION OF ARGUMENTS C C --INPUT-- C C X - ARRAY OF ABSCISSAS OF DATA (IN INCREASING ORDER) C Y - ARRAY OF ORDINATES OF DATA C N - THE NUMBER OF DATA POINTS. THE ARRAYS X, Y, YP, AND C YPP MUST BE DIMENSIONED AT LEAST N. (N .GE. 4) C ISX - MUST BE ZERO ON THE INITIAL CALL TO SPLIFT. C IF A SPLINE IS TO BE FITTED TO A SECOND SET OF DATA C THAT HAS THE SAME SET OF ABSCISSAS AS A PREVIOUS SET, C AND IF THE CONTENTS OF W HAVE NOT BEEN CHANGED SINCE C THAT PREVIOUS FIT WAS COMPUTED, THEN ISX MAY BE C SET TO ONE FOR FASTER EXECUTION. C A1,B1,AN,BN - SPECIFY THE END CONDITIONS FOR THE SPLINE WHICH C ARE EXPRESSED AS CONSTRAINTS ON THE SECOND DERIVATIVE C OF THE SPLINE AT THE END POINTS (SEE YPP). C THE END CONDITION CONSTRAINTS ARE C YPP(1) = A1*YPP(2) + B1 C AND C YPP(N) = AN*YPP(N-1) + BN C WHERE C ABS(A1).LT. 1.0 AND ABS(AN).LT. 1.0. C C THE SMOOTHEST SPLINE (I.E., LEAST INTEGRAL OF SQUARE C OF SECOND DERIVATIVE) IS OBTAINED BY A1=B1=AN=BN=0. C IN THIS CASE THERE IS AN INFLECTION AT X(1) AND X(N). C IF THE DATA IS TO BE EXTRAPOLATED (SAY, BY USING SPLINT C TO EVALUATE THE SPLINE OUTSIDE THE RANGE X(1) TO X(N)), C THEN TAKING A1=AN=0.5 AND B1=BN=0 MAY YIELD BETTER C RESULTS. IN THIS CASE THERE IS AN INFLECTION C AT X(1) - (X(2)-X(1)) AND AT X(N) + (X(N)-X(N-1)). C IN THE MORE GENERAL CASE OF A1=AN=A AND B1=BN=0, C THERE IS AN INFLECTION AT X(1) - (X(2)-X(1))*A/(1.0-A) C AND AT X(N) + (X(N)-X(N-1))*A/(1.0-A). C C A SPLINE THAT HAS A GIVEN FIRST DERIVATIVE YP1 AT X(1) C AND YPN AT Y(N) MAY BE DEFINED BY USING THE C FOLLOWING CONDITIONS. C C A1=-0.5 C C B1= 3.0*((Y(2)-Y(1))/(X(2)-X(1))-YP1)/(X(2)-X(1)) C C AN=-0.5 C C BN=-3.0*((Y(N)-Y(N-1))/(X(N)-X(N-1))-YPN)/(X(N)-X(N-1)) C C --OUTPUT-- C C YP - ARRAY OF FIRST DERIVATIVES OF SPLINE (AT THE X(I)) C YPP - ARRAY OF SECOND DERIVATIVES OF SPLINE (AT THE X(I)) C IERR - A STATUS CODE C --NORMAL CODE C 0 MEANS THAT THE REQUESTED SPLINE WAS COMPUTED. C --ABNORMAL CODES C 1 MEANS THAT ABS(A1) OR ABS(AN) WAS .GE. 1. C 2 MEANS THAT N, THE NUMBER OF POINTS, WAS .LT. 4. C 3 MEANS THE ABSCISSAS WERE NOT STRICTLY INCREASING. C C --WORK-- C C W - ARRAY OF WORKING STORAGE DIMENSIONED AT LEAST 3N. C REAL X(N), Y(N), YP(N), YPP(N), W(N,3) C IF (ABS(A1) .GE. 1.0 .OR. ABS(AN) .GE. 1.0) GO TO 100 IF (N .LT. 4) GO TO 200 NM1 = N - 1 NM2 = N - 2 IF (ISX .GT. 0) GO TO 40 DO 10 I = 2,N IF (X(I) .LE. X(I-1)) GO TO 300 10 CONTINUE C C DEFINE THE TRIDIAGONAL MATRIX C W(1,3) = X(2) - X(1) DO 20 I = 2,NM1 W(I,2) = W(I-1,3) W(I,3) = X(I+1) - X(I) W(I,1) = 2.0*(W(I,2) + W(I,3)) 20 CONTINUE W(1,1) = 4.0 W(1,3) =-4.0*A1 W(N,1) = 4.0 W(N,2) =-4.0*AN C C LU DECOMPOSITION C DO 30 I = 2,N W(I-1,3) = W(I-1,3)/W(I-1,1) W(I,1) = W(I,1) - W(I,2)*W(I-1,3) 30 CONTINUE C C DEFINE *CONSTANT* VECTOR C 40 YPP(1) = 4.0*B1 DOLD = (Y(2) - Y(1))/W(2,2) DO 50 I = 2,NM2 DNEW = (Y(I+1) - Y(I))/W(I+1,2) YPP(I) = 6.0*(DNEW - DOLD) YP(I) = DOLD DOLD = DNEW 50 CONTINUE DNEW = (Y(N) - Y(NM1))/(X(N) - X(NM1)) YPP(NM1) = 6.0*(DNEW - DOLD) YPP(N) = 4.0*BN YP(NM1)= DOLD YP(N) = DNEW C C FORWARD SUBSTITUTION C YPP(1) = YPP(1)/W(1,1) DO 60 I = 2,N YPP(I) = (YPP(I) - W(I,2)*YPP(I-1))/W(I,1) 60 CONTINUE C C BACKWARD SUBSTITUTION C DO 70 J = 1,NM1 I = N - J YPP(I) = YPP(I) - W(I,3)*YPP(I+1) 70 CONTINUE C C COMPUTE FIRST DERIVATIVES C H = X(2) - X(1) YP(1) = (Y(2) - Y(1))/H - H*(2.0*YPP(1) + YPP(2))/6.0 DO 80 I = 2,NM1 YP(I) = YP(I) + W(I,2)*(YPP(I-1) + 2.0*YPP(I))/6.0 80 CONTINUE YP(N) = YP(N) + (X(N) - X(NM1))*(YPP(NM1) + 2.0*YPP(N))/6.0 IERR = 0 RETURN C 100 IERR = 1 RETURN 200 IERR = 2 RETURN 300 IERR = 3 RETURN END SUBROUTINE SPFIT (X, Y, WGT, M, BREAK, L, Z, A, B, C, WK, IERR) C----------------------------------------------------------------------- C WEIGHTED LEAST SQUARES CUBIC SPLINE FITTING C----------------------------------------------------------------------- REAL X(M), Y(M), WGT(M), BREAK(L) REAL Z(*), A(*), B(*), C(*), WK(*) REAL TEMP(20) C--------------------- C REAL Z(L-1), A(L-1), B(L-1), C(L-1), WK(7*L + 18) C--------------------- IF (L .LT. 2) GO TO 100 N = L + 2 C C DEFINE THE KNOTS FOR THE B-SPLINES C WK(1) = BREAK(1) WK(2) = BREAK(1) WK(3) = BREAK(1) WK(4) = BREAK(1) DO 10 J = 2,L IF (BREAK(J - 1) .GE. BREAK(J)) GO TO 110 WK(J + 3) = BREAK(J) 10 CONTINUE WK(L + 4) = BREAK(L) WK(L + 5) = BREAK(L) WK(L + 6) = BREAK(L) C C OBTAIN THE B-SPLINE COEFFICIENTS OF THE LEAST SQUARES FIT C LA = N + 5 LW = LA + N LQ = LW + N CALL BSLSQ (X, Y, WGT, M, WK(1), N, 4, WK(LA), * WK(LW), WK(LQ), IERR) IF (IERR .LT. 0) GO TO 120 IERR = 0 C C OBTAIN THE COEFFICIENTS OF THE FIT IN TAYLOR SERIES FORM C CALL BSPP (WK(1), WK(LA), N, 4, BREAK, * WK(LQ), LM1, TEMP) K = LQ DO 20 J = 1,LM1 Z(J) = WK(K) A(J) = WK(K + 1) B(J) = WK(K + 2) C(J) = WK(K + 3) K = K + 4 20 CONTINUE RETURN C C ERROR RETURN C 100 IERR = 1 RETURN 110 IERR = 2 RETURN 120 IERR = 3 RETURN END SUBROUTINE CSPFIT (X, Y, M, BREAK, L, XCON, CON, NDER, NC, * Z, A, B, C, WK, IWK, IERR) C----------------------------------------------------------------------- C LEAST SQUARES CUBIC SPLINE FITTING WITH C EQUALITY AND INEQUALITY CONSTRAINTS C----------------------------------------------------------------------- REAL X(M), Y(M), BREAK(L) REAL XCON(*), CON(*) REAL Z(*), A(*), B(*), C(*), WK(*) INTEGER NDER(*), IWK(*) C REAL TEMP(20) C--------------------- C XCON, CON, NDER ARE ARRAYS OF DIMENSION MAX(1,NC). C Z, A, B, C ARE ARRAYS OF DIMENSION L - 1. C WK AND IWK ARE ARRAYS OF DIMENSION IWK(1) AND IWK(2) C RESPECTIVELY. IT IS REQUIRED THAT IWK(2) .GE. 2 C AND IWK(1) .GE. 7(L + 7) FOR ALL NC. IF NC .GE. 1 C THEN MORE STORAGE WILL BE NEEDED. C--------------------- IF (L .LT. 2) GO TO 100 N = L + 2 C C DEFINE THE KNOTS FOR THE B-SPLINES C WK(1) = BREAK(1) WK(2) = BREAK(1) WK(3) = BREAK(1) WK(4) = BREAK(1) DO 10 J = 2,L IF (BREAK(J - 1) .GE. BREAK(J)) GO TO 110 WK(J + 3) = BREAK(J) 10 CONTINUE WK(L + 4) = BREAK(L) WK(L + 5) = BREAK(L) WK(L + 6) = BREAK(L) C C OBTAIN THE B-SPLINE COEFFICIENTS OF THE LEAST SQUARES FIT C K = 7*N + 35 IF (IWK(1) .LT. K) GO TO 120 LA = N + 5 LW = LA + N IERR = 0 C K = LW - 1 IWK(1) = IWK(1) - K CALL BFIT (WK(1), N, 4, X, Y, M, XCON, CON, NDER, NC, IERR, * WK(LA), R, WK(LW), IWK) IWK(1) = IWK(1) + K IF (IERR .LT. 0 .OR. IERR .EQ. 2) RETURN C C OBTAIN THE COEFFICIENTS OF THE FIT IN TAYLOR SERIES FORM C CALL BSPP (WK(1), WK(LA), N, 4, BREAK, * WK(LW), LM1, TEMP) K = LW DO 20 J = 1,LM1 Z(J) = WK(K) A(J) = WK(K + 1) B(J) = WK(K + 2) C(J) = WK(K + 3) K = K + 4 20 CONTINUE RETURN C C ERROR RETURN C 100 IERR = -1 RETURN C 110 IERR = -3 RETURN C 120 IERR = -6 IWK(1) = K RETURN END SUBROUTINE SCOMP (X,Y,A,B,C,N,XI,YI,NI,IERR) C C ABSTRACT C C SCOMP EVALUATES A CUBIC SPLINE AT THE ABSCISSAS IN XI. C IT IS ASSUMED THAT THE COEFFICIENTS OF THE POLYNOMIALS C WHICH FORM THE SPLINE ARE PROVIDED. C C DESCRIPTION OF ARGUMENTS C C --INPUT-- C C X - ARRAY OF THE FIRST N ABSCISSAS (IN INCREASING ORDER) C THAT DEFINE THE SPLINE. C Y - ARRAY OF THE FIRST N ORDINATES THAT DEFINE THE SPLINE. C A,B,C ARRAYS THAT CONTAIN THE COEFFICIENTS OF THE POLYNOMIALS C WHICH FORM THE SPLINE. IF I = 1,...,N THEN THE SPLINE C HAS THE VALUE C Y(I) + A(I)*DX + B(I)*DX**2 + C(I)*DX**3 C FOR X(I) .LE. XX .LE. X(I+1). HERE DX = XX-X(I). C N - THE NUMBER OF POLYNOMIALS THAT DEFINE THE SPLINE. C THE ARRAYS X, Y, A, B, C MUST BE DIMENSIONED AT C LEAST N. N MUST BE GREATER THAN OR EQUAL TO 1. C XI - THE ABSCISSA OR ARRAY OF ABSCISSAS (IN ARBITRARY ORDER) C AT WHICH THE SPLINE IS TO BE EVALUATED. C NI - THE NUMBER OF ABSCISSAS AT WHICH THE SPLINE IS TO BE C EVALUATED. IF NI IS GREATER THAN 1 THEN XI AND YI C MUST BE ARRAYS OF DIMENSION NI OR LARGER. C IT IS ASSUMED THAT NI IS GREATER THAN OR EQUAL TO 1. C C --OUTPUT-- C C YI - ARRAY OF VALUES OF THE SPLINE (ORDINATES) AT XI. C IERR- STATUS CODE C 0 THE SPLINE WAS EVALUATED AT EACH ABSCISSA IN XI. C 1 INPUT ERROR - NI IS NOT POSITIVE. C REAL X(N), Y(N), A(N), B(N), C(N), XI(NI), YI(NI) C C CHECK INPUT C IF (NI .GT. 0) GO TO 1 IERR = 1 RETURN 1 IERR = 0 C C K IS INDEX ON VALUE OF XI BEING WORKED ON. XX IS THAT VALUE. C I IS CURRENT INDEX INTO X ARRAY. C K = 1 XX = XI(1) IF (XX .LT. X(1)) GO TO 90 IF (XX .GE. X(N)) GO TO 80 IL = 1 IR = N C C BISECTION SEARCH C 10 I = (IL + IR)/2 IF (I .EQ. IL) GO TO 100 IF (XX - X(I)) 20,100,30 20 IR = I GO TO 10 30 IL = I GO TO 10 C C LINEAR FORWARD SEARCH C 50 IF (XX .LT. X(I+1)) GO TO 100 I = I + 1 GO TO 50 C C XX IS GREATER THAN X(N) OR LESS THAN X(1) C 80 I = N GO TO 100 90 I = 1 C C EVALUATION C 100 DX = XX - X(I) YI(K) = Y(I) + DX*(A(I) + DX*(B(I) + DX*C(I))) C C NEXT POINT C IF (K .GE. NI) RETURN K = K + 1 XX = XI(K) IF (XX .LT. X(1)) GO TO 90 IF (XX .GE. X(N)) GO TO 80 IF (XX - XI(K-1)) 110,100,50 110 IL = 1 IR = MIN0(I+1,N) GO TO 10 END SUBROUTINE SCOMP1 (X,Y,YP,N,XI,YI,NI,IERR) C C ABSTRACT C C SCOMP1 EVALUATES A CUBIC SPLINE AT THE ABSCISSAS IN XI. C IT IS ASSUMED THAT THE FIRST DERIVATIVES AT THE NODES C HAVE BEEN PROVIDED. C C DESCRIPTION OF ARGUMENTS C C --INPUT-- C C X - ARRAY OF ABSCISSAS (IN INCREASING ORDER) THAT DEFINE THE C SPLINE. C Y - ARRAY OF ORDINATES THAT DEFINE THE SPLINE. C YP - ARRAY OF FIRST DERIVATIVES THAT DEFINE THE SPLINE. C N - THE NUMBER OF DATA POINTS THAT DEFINE THE SPLINE. C THE ARRAYS X, Y, AND YP MUST BE DIMENSIONED AT LEAST N. C N MUST BE GREATER THAN OR EQUAL TO 2. C XI - THE ABSCISSA OR ARRAY OF ABSCISSAS (IN ARBITRARY ORDER) C AT WHICH THE SPLINE IS TO BE EVALUATED. C NI - THE NUMBER OF ABSCISSAS AT WHICH THE SPLINE IS TO BE C EVALUATED. IF NI IS GREATER THAN 1 THEN XI AND YI C MUST BE ARRAYS OF DIMENSION NI OR LARGER. C IT IS ASSUMED THAT NI IS GREATER THAN OR EQUAL TO 1. C C --OUTPUT-- C C YI - ARRAY OF VALUES OF THE SPLINE (ORDINATES) AT XI. C IERR- STATUS CODE C 0 THE SPLINE WAS EVALUATED AT EACH ABSCISSA IN XI. C 1 INPUT ERROR - NI IS NOT POSITIVE. C REAL X(N), Y(N), YP(N), XI(NI), YI(NI) C C CHECK INPUT C IF (NI .GT. 0) GO TO 1 IERR = 1 RETURN 1 IERR = 0 NM1 = N - 1 C C K IS INDEX ON VALUE OF XI BEING WORKED ON. XX IS THAT VALUE. C I IS CURRENT INDEX INTO X ARRAY. C K = 1 XX = XI(1) IF (XX .LT. X(1)) GO TO 90 IF (XX .GE. X(NM1)) GO TO 80 IL = 1 IR = NM1 C C BISECTION SEARCH C 10 I = (IL + IR)/2 IF (I .EQ. IL) GO TO 100 IF (XX - X(I)) 20,100,30 20 IR = I GO TO 10 30 IL = I GO TO 10 C C LINEAR FORWARD SEARCH C 50 IF (XX .LT. X(I+1)) GO TO 100 I = I + 1 GO TO 50 C C XX IS GREATER THAN X(N) OR LESS THAN X(1) C 80 I = NM1 GO TO 100 90 I = 1 C C EVALUATION C 100 H = X(I+1) - X(I) D = (Y(I+1) - Y(I))/H A = YP(I) + YP(I+1) B = (-A - YP(I) + 3.0*D)/H C = (A - D - D)/(H*H) DX = XX - X(I) YI(K) = Y(I) + DX*(YP(I) + DX*(B + DX*C)) C C NEXT POINT C IF (K .GE. NI) RETURN K = K + 1 XX = XI(K) IF (XX .LT. X(1)) GO TO 90 IF (XX .GE. X(NM1)) GO TO 80 IF (XX - XI(K-1)) 110,100,50 110 IL = 1 IR = MIN0(I+1,NM1) GO TO 10 END SUBROUTINE SCOMP2 (X,Y,YPP,N,XI,YI,NI,IERR) C C ABSTRACT C C SCOMP2 EVALUATES A CUBIC SPLINE AT THE ABSCISSAS IN XI. C IT IS ASSUMED THAT THE SECOND DERIVATIVES AT THE NODES C HAVE BEEN PROVIDED. C C DESCRIPTION OF ARGUMENTS C C --INPUT-- C C X - ARRAY OF ABSCISSAS (IN INCREASING ORDER) THAT DEFINE THE C SPLINE. C Y - ARRAY OF ORDINATES THAT DEFINE THE SPLINE. C YPP - ARRAY OF SECOND DERIVATIVES THAT DEFINE THE SPLINE. C N - THE NUMBER OF DATA POINTS THAT DEFINE THE SPLINE. C THE ARRAYS X, Y, AND YPP MUST BE DIMENSIONED AT LEAST N. C N MUST BE GREATER THAN OR EQUAL TO 2. C XI - THE ABSCISSA OR ARRAY OF ABSCISSAS (IN ARBITRARY ORDER) C AT WHICH THE SPLINE IS TO BE EVALUATED. C NI - THE NUMBER OF ABSCISSAS AT WHICH THE SPLINE IS TO BE C EVALUATED. IF NI IS GREATER THAN 1 THEN XI AND YI C MUST BE ARRAYS OF DIMENSION NI OR LARGER. C IT IS ASSUMED THAT NI IS GREATER THAN OR EQUAL TO 1. C C --OUTPUT-- C C YI - ARRAY OF VALUES OF THE SPLINE (ORDINATES) AT XI. C IERR- STATUS CODE C 0 THE SPLINE WAS EVALUATED AT EACH ABSCISSA IN XI. C 1 INPUT ERROR - NI IS NOT POSITIVE. C REAL X(N), Y(N), YPP(N), XI(NI), YI(NI) C C CHECK INPUT C IF (NI .GT. 0) GO TO 1 IERR = 1 RETURN 1 IERR = 0 NM1 = N - 1 C C K IS INDEX ON VALUE OF XI BEING WORKED ON. XX IS THAT VALUE. C I IS CURRENT INDEX INTO X ARRAY. C K = 1 XX = XI(1) IF (XX .LT. X(1)) GO TO 90 IF (XX .GE. X(NM1)) GO TO 80 IL = 1 IR = NM1 C C BISECTION SEARCH C 10 I = (IL + IR)/2 IF (I .EQ. IL) GO TO 100 IF (XX - X(I)) 20,100,30 20 IR = I GO TO 10 30 IL = I GO TO 10 C C LINEAR FORWARD SEARCH C 50 IF (XX .LT. X(I+1)) GO TO 100 I = I + 1 GO TO 50 C C XX IS GREATER THAN X(N) OR LESS THAN X(1) C 80 I = NM1 GO TO 100 90 I = 1 C C EVALUATION C 100 H = X(I+1) - X(I) H2 = H*H XR = (X(I+1) - XX)/H XR2 = XR*XR XR3 = XR*XR2 XL = (XX - X(I))/H XL2 = XL*XL XL3 = XL*XL2 YI(K) = Y(I)*XR + Y(I+1)*XL * - H2*(YPP(I)*(XR-XR3) + YPP(I+1)*(XL-XL3))/6.0 C C NEXT POINT C IF (K .GE. NI) RETURN K = K + 1 XX = XI(K) IF (XX .LT. X(1)) GO TO 90 IF (XX .GE. X(NM1)) GO TO 80 IF (XX - XI(K-1)) 110,100,50 110 IL = 1 IR = MIN0(I+1,NM1) GO TO 10 END SUBROUTINE SEVAL (X,Y,A,B,C,N,XI,YI,YPI,YPPI,NI,IERR) C C ABSTRACT C C SEVAL EVALUATES A CUBIC SPLINE AND ITS FIRST AND SECOND C DERIVATIVES AT THE ABSCISSAS IN XI. IT IS ASSUMED THAT C THE COEFFICIENTS OF THE POLYNOMIALS WHICH FORM THE SPLINE C ARE PROVIDED. C C DESCRIPTION OF ARGUMENTS C C --INPUT-- C C X - ARRAY OF THE FIRST N ABSCISSAS (IN INCREASING ORDER) C THAT DEFINE THE SPLINE. C Y - ARRAY OF THE FIRST N ORDINATES THAT DEFINE THE SPLINE. C A,B,C ARRAYS THAT CONTAIN THE COEFFICIENTS OF THE POLYNOMIALS C WHICH FORM THE SPLINE. IF I = 1,...,N THEN THE SPLINE C HAS THE VALUE C Y(I) + A(I)*DX + B(I)*DX**2 + C(I)*DX**3 C FOR X(I) .LE. XX .LE. X(I+1). HERE DX = XX-X(I). C N - THE NUMBER OF POLYNOMIALS THAT DEFINE THE SPLINE. C THE ARRAYS X, Y, A, B, C MUST BE DIMENSIONED AT C LEAST N. N MUST BE GREATER THAN OR EQUAL TO 1. C XI - THE ABSCISSA OR ARRAY OF ABSCISSAS (IN ARBITRARY ORDER) C AT WHICH THE SPLINE IS TO BE EVALUATED. C NI - THE NUMBER OF ABSCISSAS AT WHICH THE SPLINE IS TO BE C EVALUATED. IF NI IS GREATER THAN 1, THEN XI, YI, YPI, C AND YPPI MUST BE ARRAYS DIMENSIONED AT LEAST NI. C NI MUST BE GREATER THAN OR EQUAL TO 1. C C --OUTPUT-- C C YI - ARRAY OF VALUES OF THE SPLINE (ORDINATES) AT XI. C YPI - ARRAY OF VALUES OF THE FIRST DERIVATIVE OF SPLINE AT XI. C YPPI- ARRAY OF VALUES OF SECOND DERIVATIVES OF SPLINE AT XI. C IERR- STATUS CODE C 0 THE SPLINE WAS EVALUATED AT EACH ABSCISSA IN XI. C 1 INPUT ERROR - NI IS NOT POSITIVE. C REAL X(N),Y(N),A(N),B(N),C(N),XI(NI),YI(NI),YPI(NI),YPPI(NI) C C CHECK INPUT C IF (NI .GT. 0) GO TO 1 IERR = 1 RETURN 1 IERR = 0 C C K IS INDEX ON VALUE OF XI BEING WORKED ON. XX IS THAT VALUE. C I IS CURRENT INDEX INTO X ARRAY. C K = 1 XX = XI(1) IF (XX .LT. X(1)) GO TO 90 IF (XX .GE. X(N)) GO TO 80 IL = 1 IR = N C C BISECTION SEARCH C 10 I = (IL + IR)/2 IF (I .EQ. IL) GO TO 100 IF (XX - X(I)) 20,100,30 20 IR = I GO TO 10 30 IL = I GO TO 10 C C LINEAR FORWARD SEARCH C 50 IF (XX .LT. X(I+1)) GO TO 100 I = I + 1 GO TO 50 C C XX IS GREATER THAN X(N) OR LESS THAN X(1) C 80 I = N GO TO 100 90 I = 1 C C EVALUATION C 100 DX = XX - X(I) YI(K) = Y(I) + DX*(A(I) + DX*(B(I) + DX*C(I))) BI = B(I) + B(I) CI = 3.0*C(I) YPI(K) = A(I) + DX*(BI + DX*CI) YPPI(K) = BI + DX*(CI + CI) C C NEXT POINT C IF (K .GE. NI) RETURN K = K + 1 XX = XI(K) IF (XX .LT. X(1)) GO TO 90 IF (XX .GE. X(N)) GO TO 80 IF (XX - XI(K-1)) 110,100,50 110 IL = 1 IR = MIN0(I+1,N) GO TO 10 END SUBROUTINE SEVAL1 (X,Y,YP,N,XI,YI,YPI,YPPI,NI,IERR) C C ABSTRACT C C SEVAL1 EVALUATES A CUBIC SPLINE AND ITS FIRST AND SECOND C DERIVATIVES AT THE ABSCISSAS IN XI. IT IS ASSUMED THAT C THE FIRST DERIVATIVES AT THE NODES HAVE BEEN PROVIDED. C C DESCRIPTION OF ARGUMENTS C C --INPUT-- C C X - ARRAY OF ABSCISSAS (IN INCREASING ORDER) THAT DEFINE THE C SPLINE. C Y - ARRAY OF ORDINATES THAT DEFINE THE SPLINE. C YP - ARRAY OF FIRST DERIVATIVES THAT DEFINE THE SPLINE. C N - THE NUMBER OF DATA POINTS THAT DEFINE THE SPLINE. C THE ARRAYS X, Y, AND YP MUST BE DIMENSIONED AT LEAST N. C N MUST BE GREATER THAN OR EQUAL TO 2. C XI - THE ABSCISSA OR ARRAY OF ABSCISSAS (IN ARBITRARY ORDER) C AT WHICH THE SPLINE IS TO BE EVALUATED. C NI - THE NUMBER OF ABSCISSAS AT WHICH THE SPLINE IS TO BE C EVALUATED. IF NI IS GREATER THAN 1, THEN XI, YI, YPI, C AND YPPI MUST BE ARRAYS DIMENSIONED AT LEAST NI. C NI MUST BE GREATER THAN OR EQUAL TO 1. C C --OUTPUT-- C C YI - ARRAY OF VALUES OF THE SPLINE (ORDINATES) AT XI. C YPI - ARRAY OF VALUES OF THE FIRST DERIVATIVE OF SPLINE AT XI. C YPPI- ARRAY OF VALUES OF SECOND DERIVATIVES OF SPLINE AT XI. C IERR- STATUS CODE C 0 THE SPLINE WAS EVALUATED AT EACH ABSCISSA IN XI. C 1 INPUT ERROR - NI IS NOT POSITIVE. C REAL X(N),Y(N),YP(N),XI(NI),YI(NI),YPI(NI),YPPI(NI) C C CHECK INPUT C IF (NI .GT. 0) GO TO 1 IERR = 1 RETURN 1 IERR = 0 NM1 = N - 1 C C K IS INDEX ON VALUE OF XI BEING WORKED ON. XX IS THAT VALUE. C I IS CURRENT INDEX INTO X ARRAY. C K = 1 XX = XI(1) IF (XX .LT. X(1)) GO TO 90 IF (XX .GE. X(NM1)) GO TO 80 IL = 1 IR = NM1 C C BISECTION SEARCH C 10 I = (IL + IR)/2 IF (I .EQ. IL) GO TO 100 IF (XX - X(I)) 20,100,30 20 IR = I GO TO 10 30 IL = I GO TO 10 C C LINEAR FORWARD SEARCH C 50 IF (XX .LT. X(I+1)) GO TO 100 I = I + 1 GO TO 50 C C XX IS GREATER THAN X(N) OR LESS THAN X(1) C 80 I = NM1 GO TO 100 90 I = 1 C C EVALUATION C 100 H = X(I+1) - X(I) D = (Y(I+1) - Y(I))/H A = YP(I) + YP(I+1) B = (-A - YP(I) + 3.0*D)/H C = (A - D - D)/(H*H) DX = XX - X(I) YI(K) = Y(I) + DX*(YP(I) + DX*(B + DX*C)) B = B + B C = 3.0*C YPI(K) = YP(I) + DX*(B + DX*C) YPPI(K) = B + DX*(C + C) C C NEXT POINT C IF (K .GE. NI) RETURN K = K + 1 XX = XI(K) IF (XX .LT. X(1)) GO TO 90 IF (XX .GE. X(NM1)) GO TO 80 IF (XX - XI(K-1)) 110,100,50 110 IL = 1 IR = MIN0(I+1,NM1) GO TO 10 END SUBROUTINE SEVAL2 (X,Y,YPP,N,XI,YI,YPI,YPPI,NI,IERR) C C ABSTRACT C C SEVAL2 EVALUATES A CUBIC SPLINE AND ITS FIRST AND SECOND C DERIVATIVES AT THE ABSCISSAS IN XI. IT IS ASSUMED THAT C THE SECOND DERIVATIVES AT THE NODES HAVE BEEN PROVIDED. C C DESCRIPTION OF ARGUMENTS C C --INPUT-- C C X - ARRAY OF ABSCISSAS (IN INCREASING ORDER) THAT DEFINE THE C SPLINE. C Y - ARRAY OF ORDINATES THAT DEFINE THE SPLINE. C YPP - ARRAY OF SECOND DERIVATIVES THAT DEFINE THE SPLINE. C N - THE NUMBER OF DATA POINTS THAT DEFINE THE SPLINE. C THE ARRAYS X, Y, AND YPP MUST BE DIMENSIONED AT LEAST N. C N MUST BE GREATER THAN OR EQUAL TO 2. C XI - THE ABSCISSA OR ARRAY OF ABSCISSAS (IN ARBITRARY ORDER) C AT WHICH THE SPLINE IS TO BE EVALUATED. C NI - THE NUMBER OF ABSCISSAS AT WHICH THE SPLINE IS TO BE C EVALUATED. IF NI IS GREATER THAN 1, THEN XI, YI, YPI, C AND YPPI MUST BE ARRAYS DIMENSIONED AT LEAST NI. C NI MUST BE GREATER THAN OR EQUAL TO 1. C C --OUTPUT-- C C YI - ARRAY OF VALUES OF THE SPLINE (ORDINATES) AT XI. C YPI - ARRAY OF VALUES OF THE FIRST DERIVATIVE OF SPLINE AT XI. C YPPI- ARRAY OF VALUES OF SECOND DERIVATIVES OF SPLINE AT XI. C IERR- STATUS CODE C 0 THE SPLINE WAS EVALUATED AT EACH ABSCISSA IN XI. C 1 INPUT ERROR - NI IS NOT POSITIVE. C REAL X(N),Y(N),YPP(N),XI(NI),YI(NI),YPI(NI),YPPI(NI) C C CHECK INPUT C IF (NI .GT. 0) GO TO 1 IERR = 1 RETURN 1 IERR = 0 NM1 = N - 1 C C K IS INDEX ON VALUE OF XI BEING WORKED ON. XX IS THAT VALUE. C I IS CURRENT INDEX INTO X ARRAY. C K = 1 XX = XI(1) IF (XX .LT. X(1)) GO TO 90 IF (XX .GE. X(NM1)) GO TO 80 IL = 1 IR = NM1 C C BISECTION SEARCH C 10 I = (IL + IR)/2 IF (I .EQ. IL) GO TO 100 IF (XX - X(I)) 20,100,30 20 IR = I GO TO 10 30 IL = I GO TO 10 C C LINEAR FORWARD SEARCH C 50 IF (XX .LT. X(I+1)) GO TO 100 I = I + 1 GO TO 50 C C XX IS GREATER THAN X(N) OR LESS THAN X(1) C 80 I = NM1 GO TO 100 90 I = 1 C C EVALUATION C 100 H = X(I+1) - X(I) H2 = H*H XR = (X(I+1) - XX)/H XR2 = XR*XR XR3 = XR*XR2 XL = (XX - X(I))/H XL2 = XL*XL XL3 = XL*XL2 YI(K) = Y(I)*XR + Y(I+1)*XL 1 - H2*(YPP(I)*(XR-XR3) + YPP(I+1)*(XL-XL3))/6.0 YPI(K) = (Y(I+1)-Y(I))/H 1 + H*(YPP(I)*(1.0-3.0*XR2) - YPP(I+1)*(1.0-3.0*XL2))/6.0 YPPI(K) = YPP(I)*XR + YPP(I+1)*XL C C NEXT POINT C IF (K .GE. NI) RETURN K = K + 1 XX = XI(K) IF (XX .LT. X(1)) GO TO 90 IF (XX .GE. X(NM1)) GO TO 80 IF (XX - XI(K-1)) 110,100,50 110 IL = 1 IR = MIN0(I+1,NM1) GO TO 10 END REAL FUNCTION CSINT (X, Y, A, B, C, N, ALPHA, BETA) C----------------------------------------------------------------------- C C INTEGRATING A CUBIC SPLINE C C -------------- C C X ARRAY OF THE FIRST N ABSCISSAS (IN INCREASING ORDER) C THAT DEFINE THE SPLINE. C C Y ARRAY OF THE FIRST N ORDINATES THAT DEFINE THE SPLINE. C C A,B,C ARRAYS THAT CONTAIN THE COEFFICIENTS OF THE POLYNOMIALS C WHICH FORM THE SPLINE. IF I = 1,...,N THEN THE SPLINE C HAS THE VALUE C Y(I) + A(I)*DX + B(I)*DX**2 + C(I)*DX**3 C FOR X(I) .LE. XX .LE. X(I+1). HERE DX = XX - X(I). C C N THE NUMBER OF POLYNOMIALS THAT DEFINE THE SPLINE. C THE ARRAYS X, Y, A, B, C MUST BE DIMENSIONED AT C LEAST N. N MUST BE GREATER THAN OR EQUAL TO 1. C C ALPHA LOWER LIMIT OF THE INTEGRAL. C C BETA UPPER LIMIT OF THE INTEGRAL. BETA MAY BE LESS THAN C OR GREATER THAN ALPHA. C C----------------------------------------------------------------------- REAL X(N), Y(N), A(N), B(N), C(N) C CSINT = 0.0 H = BETA - ALPHA IF (H .EQ. 0.0) RETURN IF (H .GT. 0.0) GO TO 10 A0 = BETA B0 = ALPHA GO TO 20 10 A0 = ALPHA B0 = BETA C C LOCATE THE INTERVALS CONTAINING A0 AND B0 C 20 IF (N .EQ. 1) GO TO 50 IF (A0 .GE. X(N)) GO TO 50 K = INTRVL (A0, X, N) L = INTRVL (B0, X, N) IF (B0 .GE. X(N)) L = N IF (K .EQ. L) GO TO 51 C C INTEGRATE FROM A0 TO X(K + 1) C KP1 = K + 1 H = X(KP1) - X(K) D = A0 - X(K) R = H + D H2 = H*H D2 = D*D S = H2 + D2 SUM = Y(K) + 0.5*A(K)*R + B(K)*(S + H*D)/3.0 * + 0.25*C(K)*R*S SUM = (X(KP1) - A0)*SUM C C INTEGRATE OVER THE INTERIOR INTERVALS C IF (KP1 .EQ. L) GO TO 40 LM1 = L - 1 DO 30 I = KP1,LM1 H = X(I + 1) - X(I) S = (((0.25*C(I)*H + B(I)/3.0)*H + 0.5*A(I))*H + Y(I))*H SUM = SUM + S 30 CONTINUE C C INTEGRATE FROM X(L) TO B0 C 40 H = B0 - X(L) S = (((0.25*C(L)*H + B(L)/3.0)*H + 0.5*A(L))*H + Y(L))*H CSINT = SUM + S IF (ALPHA .GT. BETA) CSINT = -CSINT RETURN C C CASE WHEN A0 AND B0 ARE IN THE SAME INTERVAL C 50 K = N 51 H = B0 - X(K) D = A0 - X(K) R = H + D H2 = H*H D2 = D*D S = H2 + D2 SUM = Y(K) + 0.5*A(K)*R + B(K)*(S + H*D)/3.0 * + 0.25*C(K)*R*S CSINT = (BETA - ALPHA)*SUM RETURN END REAL FUNCTION CSINT1 (X, Y, YP, N, A, B) C----------------------------------------------------------------------- C C INTEGRATING A CUBIC SPLINE C C -------------- C C X ARRAY OF THE FIRST N ABSCISSAS (IN INCREASING ORDER) C THAT DEFINE THE SPLINE. C C Y ARRAY OF THE FIRST N ORDINATES THAT DEFINE THE SPLINE. C C YP ARRAY OF THE FIRST DERIVATIVES THAT DEFINE THE SPLINE. C C N THE NUMBER OF KNOTS OF THE SPLINE. THE ARRAYS X, Y, C AND YP MUST HAVE DIMENSION AT LEAST N WHERE N .GE. 2. C C A LOWER LIMIT OF THE INTEGRAL. C C B UPPER LIMIT OF THE INTEGRAL. B MAY BE LESS THAN C OR GREATER THAN A. C C----------------------------------------------------------------------- REAL X(N), Y(N), YP(N) C CSINT1 = 0.0 H = B - A IF (H .EQ. 0.0) RETURN IF (H .GT. 0.0) GO TO 10 A0 = B B0 = A GO TO 20 10 A0 = A B0 = B C C LOCATE THE INTERVALS CONTAINING A0 AND B0 C 20 K = INTRVL (A0, X, N) L = INTRVL (B0, X, N) IF (K .EQ. L) GO TO 50 C C INTEGRATE FROM A0 TO X(K + 1) C KP1 = K + 1 H = X(KP1) - X(K) D = (Y(KP1) - Y(K))/H R = YP(K) + YP(KP1) BI = (-R - YP(K) + 3.0*D)/H CI = (R - D - D)/(H*H) C D = A0 - X(K) R = H + D H2 = H*H D2 = D*D S = H2 + D2 SUM = Y(K) + 0.5*YP(K)*R + BI*(S + H*D)/3.0 * + 0.25*CI*R*S SUM = (X(KP1) - A0)*SUM C C INTEGRATE OVER THE INTERIOR INTERVALS C IF (KP1 .EQ. L) GO TO 40 LM1 = L - 1 DO 30 I = KP1,LM1 IP1 = I + 1 H = X(IP1) - X(I) D = (Y(IP1) - Y(I))/H R = YP(I) + YP(IP1) BI = (-R - YP(I) + 3.0*D)/H CI = (R - D - D)/(H*H) S = (((0.25*CI*H + BI/3.0)*H + 0.5*YP(I))*H + Y(I))*H SUM = SUM + S 30 CONTINUE C C INTEGRATE FROM X(L) TO B0 C 40 LP1 = L + 1 H = X(LP1) - X(L) D = (Y(LP1) - Y(L))/H R = YP(L) + YP(LP1) BI = (-R - YP(L) + 3.0*D)/H CI = (R - D - D)/(H*H) H = B0 - X(L) S = (((0.25*CI*H + BI/3.0)*H + 0.5*YP(L))*H + Y(L))*H CSINT1 = SUM + S IF (A .GT. B) CSINT1 = -CSINT1 RETURN C C CASE WHEN A0 AND B0 ARE IN THE SAME INTERVAL C 50 KP1 = K + 1 H = X(KP1) - X(K) D = (Y(KP1) - Y(K))/H R = YP(K) + YP(KP1) BI = (-R - YP(K) + 3.0*D)/H CI = (R - D - D)/(H*H) C H = B0 - X(K) D = A0 - X(K) R = H + D H2 = H*H D2 = D*D S = H2 + D2 SUM = Y(K) + 0.5*YP(K)*R + BI*(S + H*D)/3.0 * + 0.25*CI*R*S CSINT1 = (B - A)*SUM RETURN END REAL FUNCTION CSINT2 (X, Y, YPP, N, A, B) C----------------------------------------------------------------------- C C INTEGRATING A CUBIC SPLINE C C -------------- C C X ARRAY OF THE FIRST N ABSCISSAS (IN INCREASING ORDER) C THAT DEFINE THE SPLINE. C C Y ARRAY OF THE FIRST N ORDINATES THAT DEFINE THE SPLINE. C C YPP ARRAY OF THE SECOND DERIVATIVES THAT DEFINE THE SPLINE. C C N THE NUMBER OF KNOTS OF THE SPLINE. THE ARRAYS X, Y, C AND YPP MUST HAVE DIMENSION AT LEAST N WHERE N .GE. 2. C C A LOWER LIMIT OF THE INTEGRAL. C C B UPPER LIMIT OF THE INTEGRAL. B MAY BE LESS THAN C OR GREATER THAN A. C C----------------------------------------------------------------------- REAL X(N), Y(N), YPP(N) C CSINT2 = 0.0 H = B - A IF (H .EQ. 0.0) RETURN IF (H .GT. 0.0) GO TO 10 A0 = B B0 = A GO TO 20 10 A0 = A B0 = B C C LOCATE THE INTERVALS CONTAINING A0 AND B0 C 20 K = INTRVL (A0, X, N) L = INTRVL (B0, X, N) IF (K .EQ. L) GO TO 50 C C INTEGRATE FROM A0 TO X(K + 1) C KP1 = K + 1 H = X(KP1) - X(K) D = (X(KP1) - A0)/H R = Y(K)*D + Y(KP1)*(2.0 - D) S = YPP(K)*(2.0 - D*D) + YPP(KP1)*(2.0 - D)**2 SUM = H*D*(0.5*R - H*H*D*S/24.0) C C C INTEGRATE OVER THE INTERIOR INTERVALS C IF (KP1 .EQ. L) GO TO 40 LM1 = L - 1 DO 30 I = KP1,LM1 IP1 = I + 1 H = X(IP1) - X(I) R = Y(I) + Y(IP1) S = YPP(I) + YPP(IP1) SUM = SUM + H*(0.5*R - H*H*S/24.0) 30 CONTINUE C C INTEGRATE FROM X(L) TO B0 C 40 LP1 = L + 1 H = X(LP1) - X(L) D = (B0 - X(L))/H R = Y(L)*(2.0 - D) + Y(LP1)*D S = YPP(L)*(2.0 - D)**2 + YPP(LP1)*(2.0 - D*D) CSINT2 = SUM + H*D*(0.5*R - H*H*D*S/24.0) IF (A .GT. B) CSINT2 = -CSINT2 RETURN C C CASE WHEN A0 AND B0 ARE IN THE SAME INTERVAL C 50 KP1 = K + 1 H = X(KP1) - X(K) DMA = (A - X(K))/H DMB = (B - X(K))/H DPA = (X(KP1) - A)/H DPB = (X(KP1) - B)/H R = (DPA + DPB)*Y(K) + (DMA + DMB)*Y(KP1) S = YPP(K) * (DPA + DPB)*(DMA*(2.0 - DMA) + DMB*(2.0 - DMB)) + * YPP(KP1)*(DMA + DMB)*(DPA*(2.0 - DPA) + DPB*(2.0 - DPB)) CSINT2 = (B - A)*(0.5*R - H*H*S/24.0) RETURN END SUBROUTINE PDSPL (X, Y, A, B, C, N, T, IERR) C----------------------------------------------------------------------- C PERIODIC CUBIC SPLINE INTERPOLATION C----------------------------------------------------------------------- REAL X(N), Y(*), A(*), B(*), C(*), T(*) C---------------------- C REAL X(N), Y(N-1), A(N-1), B(N-1), C(N-1), T(N-2) C---------------------- IF (N .LT. 3) GO TO 100 NM1 = N - 1 NM2 = N - 2 NM3 = N - 3 C C A STRICTLY DIAGONALLY DOMINANT SET OF EQUATIONS FOR THE C SLOPES S(I) OF THE SPLINE AT X(I) (I = 1,...,N-1) IS C GENERATED AND SOLVED BY GAUSS ELIMINATION. THE FIRST OF C THESE EQUATIONS IS OBTAINED FROM THE REQUIREMENT THAT C THE SPLINE BE PERIODIC. THIS EQUATION HAS THE FORM ... C C A(1)*S(1) + B(1)*S(2) + C(1)*S(N-1) = T(1) C B(1) = X(N) - X(NM1) H = X(2) - X(1) IF (H .LE. 0.0 .OR. B(1) .LE. 0.0) GO TO 110 DEL = (Y(1) - Y(NM1))/B(1) DELI = (Y(2) - Y(1))/H C C(1) = H A(1) = 2.0*(H + B(1)) T(1) = 3.0*(H*DEL + B(1)*DELI) IF (N .EQ. 3) GO TO 20 C C FOR THE KNOTS X(I) (I = 2,...N-2) GENERATE THE CORRESPOND- C ING EQUATIONS AND CARRY OUT THE PIVOT REDUCTION OF GAUSS C ELIMINATION. THEN THE I-TH EQUATION HAS THE FORM ... C C A(I)*S(I) + B(I)*S(I+1) + C(I)*S(N-1) = T(I) C DO 10 I = 2,NM2 B(I) = H H = X(I+1) - X(I) IF (H .LE. 0.0) GO TO 110 C E = H/A(I-1) C(I) = - E*C(I-1) A(I) = 2.0*(B(I) + H) - E*B(I-1) C DEL0 = DELI DELI = (Y(I+1) - Y(I))/H T(I) = 3.0*(H*DEL0 + B(I)*DELI) - E*T(I-1) 10 CONTINUE C 20 IERR = 0 B(NM1) = H C C SINCE IT IS REQUIRED THAT THE SPLINE BE PERIODIC, THE C EQUATION FOR THE KNOT X(N-1) HAS THE FORM ... C C ALPHA*S(1) + B(1)*S(N-2) + DELTA*S(N-1) = R C C APPLYING THE PIVOTS TO THIS EQUATION, ONE OBTAINS AFTER C EACH PIVOT OPERATION THE MODIFIED EQUATION ... C C ALPHA*S(I+1) + B(1)*S(N-2) + DELTA*S(N-1) = R C C THUS, WHEN THIS PIVOT REDUCTION IS COMPLETE, THE (N-1)-ST C EQUATION TO BE SOLVED HAS THE FORM ... C C (ALPHA + B(1))*S(N-2) + DELTA*S(N-1) = R C ALPHA = H DELTA = 2.0*(H + B(1)) R = 3.0*(B(1)*DELI + H*DEL) IF (N .EQ. 3) GO TO 40 C DO 30 I = 1,NM3 E = ALPHA/A(I) ALPHA = - E*B(I) DELTA = DELTA - E*C(I) R = R - E*T(I) 30 CONTINUE C C SOLVE THE LAST TWO EQUATIONS FOR S(N-1) AND S(N-2), AND C STORE THESE SLOPES IN A. C 40 E = (ALPHA + B(1))/A(NM2) W = B(NM2) + C(NM2) S = (R - E*T(NM2))/(DELTA - E*W) A(NM1) = S A(NM2) = (T(NM2) - W*S)/A(NM2) IF (N .EQ. 3) GO TO 60 C C BACK SUBSTITUTION TO OBTAIN THE REMAINING SLOPES S(I). C THESE SLOPES ARE STORED IN A. C SI = A(NM2) DO 50 J = 3,NM1 I = N - J SI = (T(I) - B(I)*SI - C(I)*S)/A(I) A(I) = SI 50 CONTINUE C C GENERATE THE CUBIC COEFFICIENTS B(I) AND C(I) C 60 H = B(1) DO 61 I = 1,NM2 HI = B(I + 1) DELI = (Y(I+1) - Y(I))/HI W = A(I) + A(I+1) - 2.0*DELI B(I) = (DELI - A(I) - W)/HI C(I) = (W/HI)/HI 61 CONTINUE W = A(1) + A(NM1) - 2.0*DEL B(NM1) = (DEL - A(NM1) - W)/H C(NM1) = (W/H)/H RETURN C C ERROR RETURN C 100 IERR = 1 RETURN 110 IERR = 2 RETURN END SUBROUTINE PDFIT (X, Y, M, BREAK, L, Z, A, B, C, WK, IWK, IERR) C----------------------------------------------------------------------- C LEAST SQUARES PERIODIC CUBIC SPLINE FITTING C----------------------------------------------------------------------- REAL X(M), Y(M), BREAK(L) REAL Z(*), A(*), B(*), C(*), WK(*) INTEGER IWK(*) C-------------------- C REAL Z(L-1), A(L-1), B(L-1), C(L-1) C REAL WK((L + 6)*(L + 15) + 10) C INTEGER IWK(2*L + 6) C-------------------- REAL TEMP(20) REAL CON(3), XCON(3) INTEGER NDER(3) C-------------------- DATA NDER(1) /3/, NDER(2) /7/, NDER(3) /11/ C-------------------- IF (M .LE. 0 .OR. L .LT. 2) GO TO 100 N = L + 2 C C DEFINE THE NODES FOR THE B-SPLINES C WK(1) = BREAK(1) WK(2) = BREAK(1) WK(3) = BREAK(1) WK(4) = BREAK(1) DO 10 J = 2,L IF (BREAK(J - 1) .GE. BREAK(J)) GO TO 110 WK(J + 3) = BREAK(J) 10 CONTINUE WK(L + 4) = BREAK(L) WK(L + 5) = BREAK(L) WK(L + 6) = BREAK(L) C C DEFINE THE PERIODICITY CONSTRAINTS C CON(1) = BREAK(1) CON(2) = BREAK(1) CON(3) = BREAK(1) XCON(1) = BREAK(L) XCON(2) = BREAK(L) XCON(3) = BREAK(L) C C OBTAIN THE B-SPLINE COEFFICIENTS OF THE PERIODIC SPLINE C IERR = 0 LA = N + 5 LW = LA + N IWK(1) = IWK(1) - (L + L + 8) CALL BFIT (WK(1), N, 4, X, Y, M, XCON, CON, NDER, 3, IERR, * WK(LA), R, WK(LW), IWK) IWK(1) = IWK(1) + (L + L + 8) IF (IERR .NE. 0) GO TO 30 C C OBTAIN THE COEFFICIENTS OF THE SPLINE IN TAYLOR SERIES FORM C CALL BSPP (WK(1), WK(LA), N, 4, BREAK, WK(LW), LM1, TEMP) K = LW DO 20 J = 1,LM1 Z(J) = WK(K) A(J) = WK(K + 1) B(J) = WK(K + 2) C(J) = WK(K + 3) K = K + 4 20 CONTINUE RETURN C C THE COEFFICIENTS WERE NOT OBTAINED C 30 IF (IERR .EQ. -4) GO TO 120 IF (IERR .EQ. -6) GO TO 130 IF (IERR .EQ. -7) GO TO 140 IERR = 1 RETURN C C ERROR RETURN C 100 IERR = 2 RETURN 110 IERR = 3 RETURN 120 IERR = 4 RETURN 130 IERR = 5 RETURN 140 IERR = 6 RETURN END SUBROUTINE PSCMP (X, Y, A, B, C, N, XI, YI, M, IERR) C----------------------------------------------------------------------- C EVALUATION OF A PERIODIC CUBIC SPLINE C----------------------------------------------------------------------- REAL X(N), Y(*), A(*), B(*), C(*), XI(M), YI(M) C---------------------- C REAL X(N), Y(N-1), A(N-1), B(N-1), C(N-1), XI(M), YI(M) C---------------------- IF (N .GE. 3 .AND. M .GE. 1) GO TO 1 IERR = 1 RETURN 1 IERR = 0 X1 = X(1) H = X(N) - X1 C C REDUCTION OF XI(K) TO XX WHERE X(1) .LE. XX .LT. X(N) C K = 1 T = (XI(1) - X1)/H J = T T0 = T - J IF (T0 .LT. 0.0) T0 = 1.0 + T0 XX = X1 + T0*H IF (XX .GE. X(N)) GO TO 120 IL = 1 IR = N C C BISECTION SEARCH C 10 I = (IL + IR)/2 IF (I .EQ. IL) GO TO 90 IF (XX - X(I)) 20,90,30 20 IR = I GO TO 10 30 IL = I GO TO 10 C C LINEAR FORWARD SEARCH C 40 IF (XX .LT. X(I+1)) GO TO 90 I = I + 1 GO TO 40 C C COMPUTATION WHEN X(I) .LE. XX .LT. X(I+1) C 90 DX = XX - X(I) YI(K) = ((C(I)*DX + B(I))*DX + A(I))*DX + Y(I) C C NEXT POINT C 100 IF (K .GE. M) RETURN XOLD = XX K = K + 1 T = (XI(K) - X1)/H J = T T0 = T - J IF (T0 .LT. 0.0) T0 = 1.0 + T0 XX = X1 + T0*H IF (XX .GE. X(N)) GO TO 120 IF (XX - XOLD) 110,90,40 C 110 IL = 1 IR = MIN0(I+1,N) GO TO 10 C C CASE WHEN ROUNDOFF PRODUCES A VALUE FOR XX WHERE C XX .GE. X(N). THIS CASE MAY NEVER OCCUR. C 120 I = 1 XX = X1 YI(K) = Y(1) GO TO 100 END SUBROUTINE PSEVL (X, Y, A, B, C, N, XI, YI, YPI, YPPI, M, IERR) C----------------------------------------------------------------------- C EVALUATION AND DIFFERENTIATION OF A PERIODIC CUBIC SPLINE C----------------------------------------------------------------------- REAL X(N), Y(*), A(*), B(*), C(*), XI(M), YI(M), YPI(M), YPPI(M) C---------------------- C REAL X(N), Y(N-1), A(N-1), B(N-1), C(N-1), XI(M), YI(M), YPI(M), C * YPPI(M) C---------------------- IF (N .GE. 3 .AND. M .GE. 1) GO TO 1 IERR = 1 RETURN 1 IERR = 0 X1 = X(1) H = X(N) - X1 C C REDUCTION OF XI(K) TO XX WHERE X(1) .LE. XX .LT. X(N) C K = 1 T = (XI(1) - X1)/H J = T T0 = T - J IF (T0 .LT. 0.0) T0 = 1.0 + T0 XX = X1 + T0*H IF (XX .GE. X(N)) GO TO 120 IL = 1 IR = N C C BISECTION SEARCH C 10 I = (IL + IR)/2 IF (I .EQ. IL) GO TO 90 IF (XX - X(I)) 20,90,30 20 IR = I GO TO 10 30 IL = I GO TO 10 C C LINEAR FORWARD SEARCH C 40 IF (XX .LT. X(I+1)) GO TO 90 I = I + 1 GO TO 40 C C COMPUTATION WHEN X(I) .LE. XX .LT. X(I+1) C 90 DX = XX - X(I) YI(K) = ((C(I)*DX + B(I))*DX + A(I))*DX + Y(I) BI2 = B(I) + B(I) CI3 = 3.0*C(I) YPI(K) = (CI3*DX + BI2)*DX + A(I) YPPI(K) = BI2 + (CI3 + CI3)*DX C C NEXT POINT C 100 IF (K .GE. M) RETURN XOLD = XX K = K + 1 T = (XI(K) - X1)/H J = T T0 = T - J IF (T0 .LT. 0.0) T0 = 1.0 + T0 XX = X1 + T0*H IF (XX .GE. X(N)) GO TO 120 IF (XX - XOLD) 110,90,40 C 110 IL = 1 IR = MIN0(I+1,N) GO TO 10 C C CASE WHEN ROUNDOFF PRODUCES A VALUE FOR XX WHERE C XX .GE. X(N). THIS CASE MAY NEVER OCCUR. C 120 I = 1 XX = X1 YI(K) = Y(1) YPI(K) = A(1) YPPI(K) = B(1) + B(1) GO TO 100 END SUBROUTINE CSLOOP (M, N, X, KX, T, DX, KDX, WK, IERR) C----------------------------------------------------------------------- C CLOSED CURVE CUBIC SPLINE FITTING C IN N-DIMENSIONAL SPACE C----------------------------------------------------------------------- C WRITTEN BY C ALFRED H. MORRIS C NAVAL SURFACE WARFARE CENTER C DAHLGREN, VIRGINIA C---------------------- REAL X(KX,N), T(M), DX(KDX,N), WK(*) C---------------------- C M = THE NUMBER OF N-DIMENSIONAL POINTS GIVEN IN X C WK IS AN ARRAY OF DIMENSION 4*(M-1) C---------------------- IF (MIN0(M, N) .LT. 2) GO TO 10 C MM1 = M - 1 IE = 1 IA = MM1 IB = IA + MM1 IC = IB + M CALL CSLOP1 (M, N, X, KX, T, DX, KDX, WK(IA), WK(IB), * WK(IC), WK(IE), IERR) RETURN C C ERROR RETURN C 10 IERR = 1 RETURN END SUBROUTINE CSLOP1 (M, N, X, KX, T, DX, KDX, A, B, C, E, IERR) C----------------------------------------------------------------------- C CLOSED CURVE CUBIC SPLINE FITTING C IN N-DIMENSIONAL SPACE C----------------------------------------------------------------------- REAL X(KX,N), T(M), DX(KDX,N), A(*), B(M), C(*), E(*) C---------------------- C REAL A(M-1), C(M-1), E(K) (K = MAX0(1,M-2)) C THE E ARRAY IS NOT USED WHEN M = 2. C---------------------- MM1 = M - 1 MM2 = M - 2 C C DEFINITION OF THE KNOTS T(I) (I = 1,...,M). ALSO T(M+1) = 1. C THIS LAST KNOT IS NOT STORED. C T(1) = 0.0 DO 11 I = 2,M IM1 = I - 1 DO 10 J = 1,N DX(I,J) = X(I,J) - X(IM1,J) 10 CONTINUE T(I) = T(IM1) + SNRM2(N,DX(I,1),KDX) R = T(I) - T(IM1) IF (R .EQ. 0.0) GO TO 200 11 CONTINUE C DO 20 J = 1,N DX(1,J) = X(1,J) - X(M,J) 20 CONTINUE SUM = T(M) + SNRM2(N,DX(1,1),KDX) R = SUM - T(M) IF (R .EQ. 0.0) GO TO 210 C DO 30 I = 2,M T(I) = T(I)/SUM 30 CONTINUE IERR = 0 C C FOR J = 1,...,N, A DIAGONALLY DOMINANT SET OF EQUATIONS C FOR THE SLOPES S(I,J) OF THE J-TH PERIODIC SPLINE AT T(I) C (I = 1,...,M) IS GENERATED AND SOLVED BY GAUSS ELIMINATION. C THE FIRST EQUATION IS OBTAINED FROM THE REQUIREMENT THAT C THE SPLINE BE PERIODIC. THIS EQUATION HAS THE FORM ... C C A(1)*S(1,J) + B(1)*S(2,J) + C(1)*S(M,J) = DX(1,J) C H = T(2) HM = 1.0 - T(M) C(1) = H B(1) = HM A(1) = 2.0*(H + HM) B(2) = H C DO 40 J = 1,N DELM = DX(1,J)/HM DEL1 = DX(2,J)/H DX(1,J) = 3.0*(H*DELM + HM*DEL1) DX(2,J) = DEL1 40 CONTINUE IF (M .EQ. 2) GO TO 70 C C FOR THE KNOTS T(I) (I = 2,...M-1), GENERATE THE CORRESPOND- C ING EQUATIONS AND CARRY OUT THE PIVOT REDUCTION OF GAUSS C ELIMINATION. THEN THE I-TH EQUATION HAS THE FORM ... C C A(I)*S(I,J) + B(I)*S(I+1,J) + C(I)*S(M,J) = DX(I,J) C DO 50 I = 2,MM1 IM1 = I - 1 B(I) = H H = T(I+1) - T(I) E(IM1) = H/A(IM1) C(I) = - E(IM1)*C(IM1) A(I) = 2.0*(B(I) + H) - E(IM1)*B(IM1) 50 CONTINUE B(M) = H C DO 61 J = 1,N DELI = DX(2,J) DO 60 I = 2,MM1 H = B(I+1) DEL0 = DELI DELI = DX(I+1,J)/H DX(I,J) = 3.0*(H*DEL0 + B(I)*DELI) - E(I-1)*DX(I-1,J) 60 CONTINUE DX(M,J) = DELI 61 CONTINUE C C SINCE IT IS REQUIRED THAT THE SPLINE BE PERIODIC, THE C EQUATION FOR THE KNOT T(M) HAS THE FORM ... C C ALPHA*S(1,J) + HM*S(M-1,J) + ETA*S(M,J) = DX(M,J) C C APPLYING THE PIVOTS TO THIS EQUATION, ONE OBTAINS AFTER C EACH PIVOT OPERATION THE MODIFIED EQUATION ... C C ALPHA*S(I+1,J) + HM*S(M-1,J) + ETA*S(M,J) = DX(M,J) C C THUS, WHEN THIS PIVOT REDUCTION IS COMPLETE, THE M-TH C EQUATION TO BE SOLVED HAS THE FORM ... C C (ALPHA + HM)*S(M-1,J) + ETA*S(M,J) = DX(M,J) C 70 ALPHA = H ETA = 2.0*(H + HM) DO 71 J = 1,N DEL = DX(M,J) DELM = (X(1,J) - X(M,J))/HM DX(M,J) = 3.0*(HM*DEL + H*DELM) 71 CONTINUE IF (M .EQ. 2) GO TO 90 C DO 81 I = 1,MM2 P = ALPHA/A(I) ALPHA = - P*B(I) ETA = ETA - P*C(I) DO 80 J = 1,N DX(M,J) = DX(M,J) - P*DX(I,J) 80 CONTINUE 81 CONTINUE C C SOLVE THE LAST TWO EQUATIONS FOR S(M,J) AND S(M-1,J), C AND STORE THESE SLOPES IN DX. C 90 P = (ALPHA + HM)/A(MM1) TAU = B(MM1) + C(MM1) DO 91 J = 1,N SM = (DX(M,J) - P*DX(MM1,J))/(ETA - P*TAU) DX(M,J) = SM DX(MM1,J) = (DX(MM1,J) - TAU*SM)/A(MM1) 91 CONTINUE IF (M .EQ. 2) RETURN C C BACK SUBSTITUTION TO OBTAIN THE REMAINING SLOPES S(I,J). C THESE SLOPES ARE STORED IN DX. C DO 101 J = 1,N SM = DX(M,J) SI = DX(MM1,J) I = MM1 DO 100 L = 3,M I = I - 1 SI = (DX(I,J) - B(I)*SI - C(I)*SM)/A(I) DX(I,J) = SI 100 CONTINUE 101 CONTINUE RETURN C C ERROR RETURN C 200 IERR = 2 RETURN 210 IERR = 3 RETURN END SUBROUTINE LOPCMP (M, N, T, X, KX, DX, KDX, L, TI, Z, KZ) C----------------------------------------------------------------------- C EVALUATION OF A CUBIC SPLINE CLOSED CURVE C IN N-DIMENSIONAL SPACE C----------------------------------------------------------------------- REAL T(M), X(KX,N), DX(KDX,N), TI(L), Z(KZ, N) C C REDUCTION OF TI(K) TO T0 WHERE 0 .LE. T0 .LT. 1 C K = 1 J = TI(1) T0 = TI(1) - J IF (T0 .LT. 0.0) T0 = 1.0 + T0 IF (T0 .GE. T(M)) GO TO 60 IL = 1 IR = M C C BISECTION SEARCH C 10 I = (IL + IR)/2 IF (I .EQ. IL) GO TO 50 IF (T0 - T(I)) 20,50,30 20 IR = I GO TO 10 30 IL = I GO TO 10 C C LINEAR FORWARD SEARCH C 40 IF (T0 .LT. T(I+1)) GO TO 50 I = I + 1 GO TO 40 C C COMPUTATION WHEN T(I) .LE. T0 .LT. T(I+1) C 50 H = T(I+1) - T(I) DT = T0 - T(I) DO 51 J = 1,N A = DX(I,J) D = (X(I+1,J) - X(I,J))/H W = A + DX(I+1,J) B = (-W - A + 3.0*D)/H C = ((W - D - D)/H)/H Z(K,J) = X(I,J) + DT*(A + DT*(B + DT*C)) 51 CONTINUE GO TO 100 C C COMPUTATION WHEN T0 .GE. T(M) C 60 I = M H = 1.0 - T(M) DT = T0 - T(M) DO 61 J = 1,N A = DX(M,J) D = (X(1,J) - X(M,J))/H W = A + DX(1,J) B = (-W - A + 3.0*D)/H C = ((W - D - D)/H)/H Z(K,J) = X(M,J) + DT*(A + DT*(B + DT*C)) 61 CONTINUE C C NEXT POINT C 100 IF (K .GE. L) RETURN TOLD = T0 K = K + 1 J = TI(K) T0 = TI(K) - J IF (T0 .LT. 0.0) T0 = 1.0 + T0 IF (T0 .GE. T(M)) GO TO 60 IF (T0 - TOLD) 110,50,40 C 110 IL = 1 IR = MIN0(I+1,M) GO TO 10 END SUBROUTINE LOPDF (M, N, T, X, KX, DX, KDX, TI, Z, DZ, DDZ) C----------------------------------------------------------------------- C EVALUATION AND DIFFERENTIATION OF A CUBIC SPLINE C CLOSED CURVE IN N-DIMENSIONAL SPACE C----------------------------------------------------------------------- REAL T(M), X(KX,N), DX(KDX,N), Z(N), DZ(N), DDZ(N) C C REDUCTION OF TI TO T0 WHERE 0 .LE. T0 .LT. 1 C J = TI T0 = TI - J IF (T0 .LT. 0.0) T0 = 1.0 + T0 IF (T0 .GE. T(M)) GO TO 50 IL = 1 IR = M C C BISECTION SEARCH C 10 I = (IL + IR)/2 IF (I .EQ. IL) GO TO 40 IF (T0 - T(I)) 20,40,30 20 IR = I GO TO 10 30 IL = I GO TO 10 C C COMPUTATION WHEN T(I) .LE. T0 .LT. T(I+1) C 40 H = T(I+1) - T(I) DT = T0 - T(I) DO 41 J = 1,N A = DX(I,J) D = (X(I+1,J) - X(I,J))/H W = A + DX(I+1,J) B = (-W - A + 3.0*D)/H C = ((W - D - D)/H)/H Z(J) = X(I,J) + DT*(A + DT*(B + DT*C)) B = B + B C = 3.0*C DZ(J) = A + DT*(B + C*DT) DDZ(J) = B + (C + C)*DT 41 CONTINUE RETURN C C COMPUTATION WHEN T0 .GE. T(M) C 50 H = 1.0 - T(M) DT = T0 - T(M) DO 51 J = 1,N A = DX(M,J) D = (X(1,J) - X(M,J))/H W = A + DX(1,J) B = (-W - A + 3.0*D)/H C = ((W - D - D)/H)/H Z(J) = X(M,J) + DT*(A + DT*(B + DT*C)) B = B + B C = 3.0*C DZ(J) = A + DT*(B + C*DT) DDZ(J) = B + (C + C)*DT 51 CONTINUE RETURN END SUBROUTINE CURV1 (N,X,Y,SLP1,SLPN,ISLPSW,YP,TEMP, * SIGMA,IERR) C INTEGER N,ISLPSW,IERR REAL X(N),Y(N),SLP1,SLPN,YP(N),TEMP(N),SIGMA C C FROM THE SPLINE UNDER TENSION PACKAGE C CODED BY A. K. CLINE AND R. J. RENKA C DEPARTMENT OF COMPUTER SCIENCES C UNIVERSITY OF TEXAS AT AUSTIN C C THIS SUBROUTINE DETERMINES THE PARAMETERS NECESSARY TO C COMPUTE AN INTERPOLATORY SPLINE UNDER TENSION THROUGH C A SEQUENCE OF FUNCTIONAL VALUES. THE SLOPES AT THE TWO C ENDS OF THE CURVE MAY BE SPECIFIED OR OMITTED. FOR ACTUAL C COMPUTATION OF POINTS ON THE CURVE IT IS NECESSARY TO CALL C THE FUNCTION CURV2. C C ON INPUT-- C C N IS THE NUMBER OF VALUES TO BE INTERPOLATED (N.GE.2). C C X IS AN ARRAY OF THE N INCREASING ABSCISSAE OF THE C FUNCTIONAL VALUES. C C Y IS AN ARRAY OF THE N ORDINATES OF THE VALUES, (I. E. C Y(K) IS THE FUNCTIONAL VALUE CORRESPONDING TO X(K) ). C C SLP1 AND SLPN CONTAIN THE DESIRED VALUES FOR THE FIRST C DERIVATIVE OF THE CURVE AT X(1) AND X(N), RESPECTIVELY. C THE USER MAY OMIT VALUES FOR EITHER OR BOTH OF THESE C PARAMETERS AND SIGNAL THIS WITH ISLPSW. C C ISLPSW CONTAINS A SWITCH INDICATING WHICH SLOPE DATA C SHOULD BE USED AND WHICH SHOULD BE ESTIMATED BY THIS C SUBROUTINE, C = 0 IF SLP1 AND SLPN ARE TO BE USED, C = 1 IF SLP1 IS TO BE USED BUT NOT SLPN, C = 2 IF SLPN IS TO BE USED BUT NOT SLP1, C = 3 IF BOTH SLP1 AND SLPN ARE TO BE ESTIMATED C INTERNALLY. C C YP IS AN ARRAY OF LENGTH AT LEAST N. C C TEMP IS AN ARRAY OF LENGTH AT LEAST N WHICH IS USED FOR C SCRATCH STORAGE. C C AND C C SIGMA CONTAINS THE TENSION FACTOR. THIS VALUE INDICATES C THE CURVINESS DESIRED. IF ABS(SIGMA) IS NEARLY ZERO C (E.G. .001) THE RESULTING CURVE IS APPROXIMATELY A C CUBIC SPLINE. IF ABS(SIGMA) IS LARGE (E.G. 50.) THE C RESULTING CURVE IS NEARLY A POLYGONAL LINE. IF SIGMA C EQUALS ZERO A CUBIC SPLINE RESULTS. A STANDARD VALUE C FOR SIGMA IS APPROXIMATELY 1. IN ABSOLUTE VALUE. C C ON OUTPUT-- C C YP CONTAINS THE VALUES OF THE SECOND DERIVATIVE OF THE C CURVE AT THE GIVEN NODES. C C IERR CONTAINS AN ERROR FLAG, C = 0 FOR NORMAL RETURN, C = 1 IF N IS LESS THAN 2, C = 2 IF X-VALUES ARE NOT STRICTLY INCREASING. C C AND C C N, X, Y, SLP1, SLPN, ISLPSW AND SIGMA ARE UNALTERED. C C THIS SUBROUTINE REFERENCES PACKAGE MODULES CEEZ, TERMS, C AND SNHCSH. C C----------------------------------------------------------- C NM1 = N-1 NP1 = N+1 IERR = 0 IF (N .LE. 1) GO TO 8 IF (X(N) .LE. X(1)) GO TO 9 C C DENORMALIZE TENSION FACTOR C SIGMAP = ABS(SIGMA)*FLOAT(N-1)/(X(N)-X(1)) C C APPROXIMATE END SLOPES C IF (ISLPSW .GE. 2) GO TO 1 SLPP1 = SLP1 GO TO 2 1 DELX1 = X(2)-X(1) DELX2 = DELX1+DELX1 IF (N .GT. 2) DELX2 = X(3)-X(1) IF (DELX1 .LE. 0. .OR. DELX2 .LE. DELX1) GO TO 9 CALL CEEZ (DELX1,DELX2,SIGMAP,C1,C2,C3,N) SLPP1 = C1*Y(1)+C2*Y(2) IF (N .GT. 2) SLPP1 = SLPP1+C3*Y(3) 2 IF (ISLPSW .EQ. 1 .OR. ISLPSW .EQ. 3) GO TO 3 SLPPN = SLPN GO TO 4 3 DELXN = X(N)-X(NM1) DELXNM = DELXN+DELXN IF (N .GT. 2) DELXNM = X(N)-X(N-2) IF (DELXN .LE. 0. .OR. DELXNM .LE. DELXN) GO TO 9 CALL CEEZ (-DELXN,-DELXNM,SIGMAP,C1,C2,C3,N) SLPPN = C1*Y(N)+C2*Y(NM1) IF (N .GT. 2) SLPPN = SLPPN+C3*Y(N-2) C C SET UP RIGHT HAND SIDE AND TRIDIAGONAL SYSTEM FOR YP AND C PERFORM FORWARD ELIMINATION C 4 DELX1 = X(2)-X(1) IF (DELX1 .LE. 0.) GO TO 9 DX1 = (Y(2)-Y(1))/DELX1 CALL TERMS (DIAG1,SDIAG1,SIGMAP,DELX1) YP(1) = (DX1-SLPP1)/DIAG1 TEMP(1) = SDIAG1/DIAG1 IF (N .EQ. 2) GO TO 6 DO 5 I = 2,NM1 DELX2 = X(I+1)-X(I) IF (DELX2 .LE. 0.) GO TO 9 DX2 = (Y(I+1)-Y(I))/DELX2 CALL TERMS (DIAG2,SDIAG2,SIGMAP,DELX2) DIAG = DIAG1+DIAG2-SDIAG1*TEMP(I-1) YP(I) = (DX2-DX1-SDIAG1*YP(I-1))/DIAG TEMP(I) = SDIAG2/DIAG DX1 = DX2 DIAG1 = DIAG2 5 SDIAG1 = SDIAG2 6 DIAG = DIAG1-SDIAG1*TEMP(NM1) YP(N) = (SLPPN-DX1-SDIAG1*YP(NM1))/DIAG C C PERFORM BACK SUBSTITUTION C DO 7 I = 2,N IBAK = NP1-I 7 YP(IBAK) = YP(IBAK)-TEMP(IBAK)*YP(IBAK+1) RETURN C C TOO FEW POINTS C 8 IERR = 1 RETURN C C X-VALUES NOT STRICTLY INCREASING C 9 IERR = 2 RETURN END FUNCTION CURV2 (T,N,X,Y,YP,SIGMA) C INTEGER N REAL T,X(N),Y(N),YP(N),SIGMA C C FROM THE SPLINE UNDER TENSION PACKAGE C CODED BY A. K. CLINE AND R. J. RENKA C DEPARTMENT OF COMPUTER SCIENCES C UNIVERSITY OF TEXAS AT AUSTIN C C THIS FUNCTION INTERPOLATES A CURVE AT A GIVEN POINT C USING A SPLINE UNDER TENSION. THE SUBROUTINE CURV1 SHOULD C BE CALLED EARLIER TO DETERMINE CERTAIN NECESSARY C PARAMETERS. C C ON INPUT-- C C T CONTAINS A REAL VALUE TO BE MAPPED ONTO THE INTERPO- C LATING CURVE. C C N CONTAINS THE NUMBER OF POINTS WHICH WERE SPECIFIED TO C DETERMINE THE CURVE. C C X AND Y ARE ARRAYS CONTAINING THE ABSCISSAE AND C ORDINATES, RESPECTIVELY, OF THE SPECIFIED POINTS. C C YP IS AN ARRAY OF SECOND DERIVATIVE VALUES OF THE CURVE C AT THE NODES. C C AND C C SIGMA CONTAINS THE TENSION FACTOR (ITS SIGN IS IGNORED). C C THE PARAMETERS N, X, Y, YP, AND SIGMA SHOULD BE INPUT C UNALTERED FROM THE OUTPUT OF CURV1. C C ON OUTPUT-- C C CURV2 CONTAINS THE INTERPOLATED VALUE. C C NONE OF THE INPUT PARAMETERS ARE ALTERED. C C THIS FUNCTION REFERENCES PACKAGE MODULES INTRVL AND C SNHCSH. C C----------------------------------------------------------- C C DETERMINE INTERVAL C IM1 = INTRVL(T,X,N) I = IM1+1 C C DENORMALIZE TENSION FACTOR C SIGMAP = ABS(SIGMA)*FLOAT(N-1)/(X(N)-X(1)) C C SET UP AND PERFORM INTERPOLATION C DEL1 = T-X(IM1) DEL2 = X(I)-T DELS = X(I)-X(IM1) SUM = (Y(I)*DEL1+Y(IM1)*DEL2)/DELS IF (SIGMAP .NE. 0.) GO TO 1 CURV2 = SUM-DEL1*DEL2*(YP(I)*(DEL1+DELS)+YP(IM1)* * (DEL2+DELS))/(6.*DELS) RETURN 1 DELP1 = SIGMAP*(DEL1+DELS)/2. DELP2 = SIGMAP*(DEL2+DELS)/2. CALL SNHCSH (SINHM1,DUMMY,SIGMAP*DEL1,-1) CALL SNHCSH (SINHM2,DUMMY,SIGMAP*DEL2,-1) CALL SNHCSH (SINHMS,DUMMY,SIGMAP*DELS,-1) CALL SNHCSH (SINHP1,DUMMY,SIGMAP*DEL1/2.,-1) CALL SNHCSH (SINHP2,DUMMY,SIGMAP*DEL2/2.,-1) CALL SNHCSH (DUMMY,COSHP1,DELP1,1) CALL SNHCSH (DUMMY,COSHP2,DELP2,1) CURV2 = SUM+(YP(I)*(SINHM1*DEL2-DEL1*(2.*(COSHP1+1.)* * SINHP2+SIGMAP*COSHP1*DEL2))+YP(IM1)*(SINHM2* * DEL1-DEL2*(2.*(COSHP2+1.)*SINHP1+SIGMAP* * COSHP2*DEL1)))/(SIGMAP*SIGMAP*DELS*(SINHMS+ * SIGMAP*DELS)) RETURN END FUNCTION CURVD (T,N,X,Y,YP,SIGMA) C INTEGER N REAL T,X(N),Y(N),YP(N),SIGMA C C FROM THE SPLINE UNDER TENSION PACKAGE C CODED BY A. K. CLINE AND R. J. RENKA C DEPARTMENT OF COMPUTER SCIENCES C UNIVERSITY OF TEXAS AT AUSTIN C C THIS FUNCTION DIFFERENTIATES A CURVE AT A GIVEN POINT C USING A SPLINE UNDER TENSION. THE SUBROUTINE CURV1 SHOULD C BE CALLED EARLIER TO DETERMINE CERTAIN NECESSARY C PARAMETERS. C C ON INPUT-- C C T CONTAINS A REAL VALUE AT WHICH THE DERIVATIVE IS TO BE C DETERMINED. C C N CONTAINS THE NUMBER OF POINTS WHICH WERE SPECIFIED TO C DETERMINE THE CURVE. C C X AND Y ARE ARRAYS CONTAINING THE ABSCISSAE AND C ORDINATES, RESPECTIVELY, OF THE SPECIFIED POINTS. C C YP IS AN ARRAY OF SECOND DERIVATIVE VALUES OF THE CURVE C AT THE NODES. C C AND C C SIGMA CONTAINS THE TENSION FACTOR (ITS SIGN IS IGNORED). C C THE PARAMETERS N, X, Y, YP, AND SIGMA SHOULD BE INPUT C UNALTERED FROM THE OUTPUT OF CURV1. C C ON OUTPUT-- C C CURVD CONTAINS THE DERIVATIVE VALUE. C C NONE OF THE INPUT PARAMETERS ARE ALTERED. C C THIS FUNCTION REFERENCES PACKAGE MODULES INTRVL AND C SNHCSH. C C----------------------------------------------------------- C C DETERMINE INTERVAL C IM1 = INTRVL(T,X,N) I = IM1+1 C C DENORMALIZE TENSION FACTOR C SIGMAP = ABS(SIGMA)*FLOAT(N-1)/(X(N)-X(1)) C C SET UP AND PERFORM DIFFERENTIATION C DEL1 = T-X(IM1) DEL2 = X(I)-T DELS = X(I)-X(IM1) SUM = (Y(I)-Y(IM1))/DELS IF (SIGMAP .NE. 0.) GO TO 1 CURVD = SUM+(YP(I)*(2.*DEL1*DEL1-DEL2*(DEL1+DELS))- * YP(IM1)*(2.*DEL2*DEL2-DEL1*(DEL2+DELS))) * /(6.*DELS) RETURN 1 CALL SNHCSH (DUMMY,COSHM1,SIGMAP*DEL1,1) CALL SNHCSH (DUMMY,COSHM2,SIGMAP*DEL2,1) CALL SNHCSH (SINHMS,DUMMY,SIGMAP*DELS,-1) CURVD = SUM+(YP(I)*(DELS*SIGMAP*COSHM1-SINHMS)- * YP(IM1)*(DELS*SIGMAP*COSHM2-SINHMS))/ * (SIGMAP*SIGMAP*DELS*(SINHMS+SIGMAP*DELS)) RETURN END FUNCTION CURVI (XL,XU,N,X,Y,YP,SIGMA) C INTEGER N REAL XL,XU,X(N),Y(N),YP(N),SIGMA C C FROM THE SPLINE UNDER TENSION PACKAGE C CODED BY A. K. CLINE AND R. J. RENKA C DEPARTMENT OF COMPUTER SCIENCES C UNIVERSITY OF TEXAS AT AUSTIN C C THIS FUNCTION INTEGRATES A CURVE SPECIFIED BY A SPLINE C UNDER TENSION BETWEEN TWO GIVEN LIMITS. THE SUBROUTINE C CURV1 SHOULD BE CALLED EARLIER TO DETERMINE NECESSARY C PARAMETERS. C C ON INPUT-- C C XL AND XU CONTAIN THE LOWER AND UPPER LIMITS OF INTE- C GRATION, RESPECTIVELY. (XL NEED NOT BE LESS THAN OR C EQUAL TO XU, CURVI (XL,XU,...) .EQ. -CURVI (XU,XL,...) ). C C N CONTAINS THE NUMBER OF POINTS WHICH WERE SPECIFIED TO C DETERMINE THE CURVE. C C X AND Y ARE ARRAYS CONTAINING THE ABSCISSAE AND C ORDINATES, RESPECTIVELY, OF THE SPECIFIED POINTS. C C YP IS AN ARRAY OF SECOND DERIVATIVE VALUES OF THE CURVE C AT THE NODES. C C AND C C SIGMA CONTAINS THE TENSION FACTOR (ITS SIGN IS IGNORED). C C THE PARAMETERS N, X, Y, YP, AND SIGMA SHOULD BE INPUT C UNALTERED FROM THE OUTPUT OF CURV1. C C ON OUTPUT-- C C CURVI CONTAINS THE INTEGRAL VALUE. C C NONE OF THE INPUT PARAMETERS ARE ALTERED. C C THIS FUNCTION REFERENCES PACKAGE MODULES INTRVL AND C SNHCSH. C C----------------------------------------------------------- C C STATEMENT FUNCTION FOR COEFFICIENT ASSOCIATED WITH C DERIVATIVE TERMS C TERM (CMM1,CMM2,T) = (CMM1-CMM2-SIGMAP*T*SS)/(SIGMAP* * SIGMAP*SIGMAP*(SS+SIGMAP*DELS)) C C DENORMALIZE TENSION FACTOR C SIGMAP = ABS(SIGMA)*FLOAT(N-1)/(X(N)-X(1)) C C DETERMINE ACTUAL UPPER AND LOWER BOUNDS C XXL = XL XXU = XU SSIGN = 1. IF (XL .LT. XU) GO TO 1 XXL = XU XXU = XL SSIGN = -1. IF (XL .GT. XU) GO TO 1 C C RETURN ZERO IF XL .EQ. XU C CURVI = 0. RETURN C C SEARCH FOR PROPER INTERVALS C 1 ILM1 = INTRVL (XXL,X,N) IL = ILM1+1 IUM1 = INTRVL (XXU,X,N) IU = IUM1+1 IF (IL .EQ. IU) GO TO 8 C C INTEGRATE FROM XXL TO X(IL) C SUM = 0. IF (XXL .EQ. X(IL)) GO TO 3 DEL1 = XXL-X(ILM1) DEL2 = X(IL)-XXL DELS = X(IL)-X(ILM1) T1 = (DEL1+DELS)*DEL2/(2.*DELS) T2 = DEL2*DEL2/(2.*DELS) SUM = T1*Y(IL)+T2*Y(ILM1) IF (SIGMA .EQ. 0.) GO TO 2 CALL SNHCSH (DUMMY,C1,SIGMAP*DEL1,2) CALL SNHCSH (DUMMY,C2,SIGMAP*DEL2,2) CALL SNHCSH (SS,CS,SIGMAP*DELS,3) SUM = SUM+TERM(CS,C1,T1)*YP(IL) * +TERM(C2,0.,T2)*YP(ILM1) GO TO 3 2 SUM = SUM-T1*T1*DELS*YP(IL)/6. * -T2*(DEL1*(DEL2+DELS)+DELS*DELS)*YP(ILM1)/12. C C INTEGRATE OVER INTERIOR INTERVALS C 3 IF (IU-IL .EQ. 1) GO TO 6 ILP1 = IL+1 DO 5 I = ILP1,IUM1 DELS = X(I)-X(I-1) SUM = SUM+(Y(I)+Y(I-1))*DELS/2. IF (SIGMA .EQ. 0.) GO TO 4 CALL SNHCSH (SS,CS,SIGMAP*DELS,3) SUM = SUM+(YP(I)+YP(I-1))*(CS-SS*SIGMAP*DELS/2.)/ * (SIGMAP*SIGMAP*SIGMAP*(SS+SIGMAP*DELS)) GO TO 5 4 SUM = SUM-(YP(I)+YP(I-1))*DELS*DELS*DELS/24. 5 CONTINUE C C INTEGRATE FROM X(IU-1) TO XXU C 6 IF (XXU .EQ. X(IUM1)) GO TO 10 DEL1 = XXU-X(IUM1) DEL2 = X(IU)-XXU DELS = X(IU)-X(IUM1) T1 = DEL1*DEL1/(2.*DELS) T2 = (DEL2+DELS)*DEL1/(2.*DELS) SUM = SUM+T1*Y(IU)+T2*Y(IUM1) IF (SIGMA .EQ. 0.) GO TO 7 CALL SNHCSH (DUMMY,C1,SIGMAP*DEL1,2) CALL SNHCSH (DUMMY,C2,SIGMAP*DEL2,2) CALL SNHCSH (SS,CS,SIGMAP*DELS,3) SUM = SUM+TERM(C1,0.,T1)*YP(IU) * +TERM(CS,C2,T2)*YP(IUM1) GO TO 10 7 SUM = SUM-T1*(DEL2*(DEL1+DELS)+DELS*DELS)*YP(IU)/12. * -T2*T2*DELS*YP(IUM1)/6. GO TO 10 C C INTEGRATE FROM XXL TO XXU C 8 DELU1 = XXU-X(IUM1) DELU2 = X(IU)-XXU DELL1 = XXL-X(IUM1) DELL2 = X(IU)-XXL DELS = X(IU)-X(IUM1) DELI = XXU-XXL T1 = (DELU1+DELL1)*DELI/(2.*DELS) T2 = (DELU2+DELL2)*DELI/(2.*DELS) SUM = T1*Y(IU)+T2*Y(IUM1) IF (SIGMA .EQ. 0.) GO TO 9 CALL SNHCSH (DUMMY,CU1,SIGMAP*DELU1,2) CALL SNHCSH (DUMMY,CU2,SIGMAP*DELU2,2) CALL SNHCSH (DUMMY,CL1,SIGMAP*DELL1,2) CALL SNHCSH (DUMMY,CL2,SIGMAP*DELL2,2) CALL SNHCSH (SS,DUMMY,SIGMAP*DELS,-1) SUM = SUM+TERM(CU1,CL1,T1)*YP(IU) * +TERM(CL2,CU2,T2)*YP(IUM1) GO TO 10 9 SUM = SUM-T1*(DELU2*(DELS+DELU1)+DELL2*(DELS+DELL1))* * YP(IU)/12. * -T2*(DELL1*(DELS+DELL2)+DELU1*(DELS+DELU2))* * YP(IUM1)/12. C C CORRECT SIGN AND RETURN C 10 CURVI = SSIGN*SUM RETURN END SUBROUTINE KURV1 (N,X,Y,SLP1,SLPN,ISLPSW,XP,YP,TEMP,S, * SIGMA,IERR) C INTEGER N,ISLPSW,IERR REAL X(N),Y(N),SLP1,SLPN,XP(N),YP(N),TEMP(N),S(N), * SIGMA C C FROM THE SPLINE UNDER TENSION PACKAGE C CODED BY A. K. CLINE AND R. J. RENKA C DEPARTMENT OF COMPUTER SCIENCES C UNIVERSITY OF TEXAS AT AUSTIN C C THIS SUBROUTINE DETERMINES THE PARAMETERS NECESSARY TO C COMPUTE A SPLINE UNDER TENSION FORMING A CURVE IN THE C PLANE AND PASSING THROUGH A SEQUENCE OF PAIRS (X(1),Y(1)), C ...,(X(N),Y(N)). FOR ACTUAL COMPUTATION OF POINTS ON THE C CURVE IT IS NECESSARY TO CALL THE SUBROUTINE KURV2. C C ON INPUT-- C C N IS THE NUMBER OF POINTS TO BE INTERPOLATED (N.GE.2). C C X IS AN ARRAY CONTAINING THE N X-COORDINATES OF THE C POINTS. C C Y IS AN ARRAY CONTAINING THE N Y-COORDINATES OF THE C POINTS. (ADJACENT X-Y PAIRS MUST BE DISTINCT, I. E. C EITHER X(I) .NE. X(I+1) OR Y(I) .NE. Y(I+1), FOR C I = 1,...,N-1.) C C SLP1 AND SLPN CONTAIN THE DESIRED VALUES FOR THE ANGLES C (IN RADIANS) OF THE SLOPE AT (X(1),Y(1)) AND (X(N),Y(N)) C RESPECTIVELY. THE ANGLES ARE MEASURED COUNTER-CLOCK- C WISE FROM THE X-AXIS AND THE POSITIVE SENSE OF THE CURVE C IS ASSUMED TO BE THAT MOVING FROM POINT 1 TO POINT N. C THE USER MAY OMIT VALUES FOR EITHER OR BOTH OF THESE C PARAMETERS AND SIGNAL THIS WITH ISLPSW. C C ISLPSW CONTAINS A SWITCH INDICATING WHICH SLOPE DATA C SHOULD BE USED AND WHICH SHOULD BE ESTIMATED BY THIS C SUBROUTINE, C = 0 IF SLP1 AND SLPN ARE TO BE USED, C = 1 IF SLP1 IS TO BE USED BUT NOT SLPN, C = 2 IF SLPN IS TO BE USED BUT NOT SLP1, C = 3 IF BOTH SLP1 AND SLPN ARE TO BE ESTIMATED C INTERNALLY. C C XP AND YP ARE ARRAYS OF LENGTH AT LEAST N. C C TEMP IS AN ARRAY OF LENGTH AT LEAST N WHICH IS USED C FOR SCRATCH STORAGE. C C S IS AN ARRAY OF LENGTH AT LEAST N. C C AND C C SIGMA CONTAINS THE TENSION FACTOR. THIS VALUE INDICATES C THE CURVINESS DESIRED. IF ABS(SIGMA) IS NEARLY ZERO C (E.G. .001) THE RESULTING CURVE IS APPROXIMATELY A CUBIC C SPLINE. IF ABS(SIGMA) IS LARGE (E. G. 50.) THE RESULTING C CURVE IS NEARLY A POLYGONAL LINE. IF SIGMA EQUALS ZERO A C CUBIC SPLINE RESULTS. A STANDARD VALUE FOR SIGMA IS C APPROXIMATELY 1. IN ABSOLUTE VALUE. C C ON OUTPUT-- C C XP AND YP CONTAIN INFORMATION ABOUT THE CURVATURE OF THE C CURVE AT THE GIVEN NODES. C C S CONTAINS THE POLYGONAL ARCLENGTHS OF THE CURVE. C C IERR CONTAINS AN ERROR FLAG, C = 0 FOR NORMAL RETURN, C = 1 IF N IS LESS THAN 2, C = 2 IF ADJACENT COORDINATE PAIRS COINCIDE. C C AND C C N, X, Y, SLP1, SLPN, ISLPSW, AND SIGMA ARE UNALTERED. C C THIS SUBROUTINE REFERENCES PACKAGE MODULES CEEZ, TERMS, C AND SNHCSH. C C----------------------------------------------------------- C NM1 = N-1 NP1 = N+1 IERR = 0 IF (N .LE. 1) GO TO 11 C C DETERMINE POLYGONAL ARCLENGTHS C S(1) = 0. DO 1 I = 2,N IM1 = I-1 1 S(I) = S(IM1)+SQRT((X(I)-X(IM1))**2+ * (Y(I)-Y(IM1))**2) C C DENORMALIZE TENSION FACTOR C SIGMAP = ABS(SIGMA)*FLOAT(N-1)/S(N) C C APPROXIMATE END SLOPES C IF (ISLPSW .GE. 2) GO TO 2 SLPP1X = COS(SLP1) SLPP1Y = SIN(SLP1) GO TO 4 2 DELS1 = S(2)-S(1) DELS2 = DELS1+DELS1 IF (N .GT. 2) DELS2 = S(3)-S(1) IF (DELS1 .EQ. 0. .OR. DELS2 .EQ. 0.) GO TO 12 CALL CEEZ (DELS1,DELS2,SIGMAP,C1,C2,C3,N) SX = C1*X(1)+C2*X(2) SY = C1*Y(1)+C2*Y(2) IF (N .EQ. 2) GO TO 3 SX = SX+C3*X(3) SY = SY+C3*Y(3) 3 DELT = SQRT(SX*SX+SY*SY) SLPP1X = SX/DELT SLPP1Y = SY/DELT 4 IF (ISLPSW .EQ. 1 .OR. ISLPSW .EQ. 3) GO TO 5 SLPPNX = COS(SLPN) SLPPNY = SIN(SLPN) GO TO 7 5 DELSN = S(N)-S(NM1) DELSNM = DELSN+DELSN IF (N .GT. 2) DELSNM = S(N)-S(N-2) IF (DELSN .EQ. 0. .OR. DELSNM .EQ. 0.) GO TO 12 CALL CEEZ (-DELSN,-DELSNM,SIGMAP,C1,C2,C3,N) SX = C1*X(N)+C2*X(NM1) SY = C1*Y(N)+C2*Y(NM1) IF (N .EQ. 2) GO TO 6 SX = SX+C3*X(N-2) SY = SY+C3*Y(N-2) 6 DELT = SQRT(SX*SX+SY*SY) SLPPNX = SX/DELT SLPPNY = SY/DELT C C SET UP RIGHT HAND SIDES AND TRIDIAGONAL SYSTEM FOR XP AND C YP AND PERFORM FORWARD ELIMINATION C 7 DX1 = (X(2)-X(1))/S(2) DY1 = (Y(2)-Y(1))/S(2) CALL TERMS (DIAG1,SDIAG1,SIGMAP,S(2)) XP(1) = (DX1-SLPP1X)/DIAG1 YP(1) = (DY1-SLPP1Y)/DIAG1 TEMP(1) = SDIAG1/DIAG1 IF (N .EQ. 2) GO TO 9 DO 8 I = 2,NM1 DELS2 = S(I+1)-S(I) IF (DELS2 .EQ. 0.) GO TO 12 DX2 = (X(I+1)-X(I))/DELS2 DY2 = (Y(I+1)-Y(I))/DELS2 CALL TERMS (DIAG2,SDIAG2,SIGMAP,DELS2) DIAG = DIAG1+DIAG2-SDIAG1*TEMP(I-1) DIAGIN = 1./DIAG XP(I) = (DX2-DX1-SDIAG1*XP(I-1))*DIAGIN YP(I) = (DY2-DY1-SDIAG1*YP(I-1))*DIAGIN TEMP(I) = SDIAG2*DIAGIN DX1 = DX2 DY1 = DY2 DIAG1 = DIAG2 8 SDIAG1 = SDIAG2 9 DIAG = DIAG1-SDIAG1*TEMP(NM1) XP(N) = (SLPPNX-DX1-SDIAG1*XP(NM1))/DIAG YP(N) = (SLPPNY-DY1-SDIAG1*YP(NM1))/DIAG C C PERFORM BACK SUBSTITUTION C DO 10 I = 2,N IBAK = NP1-I XP(IBAK) = XP(IBAK)-TEMP(IBAK)*XP(IBAK+1) 10 YP(IBAK) = YP(IBAK)-TEMP(IBAK)*YP(IBAK+1) RETURN C C TOO FEW POINTS C 11 IERR = 1 RETURN C C COINCIDENT ADJACENT POINTS C 12 IERR = 2 RETURN END SUBROUTINE KURV2 (T,XS,YS,N,X,Y,XP,YP,S,SIGMA) C INTEGER N REAL T,XS,YS,X(N),Y(N),XP(N),YP(N),S(N),SIGMA C C FROM THE SPLINE UNDER TENSION PACKAGE C CODED BY A. K. CLINE AND R. J. RENKA C DEPARTMENT OF COMPUTER SCIENCES C UNIVERSITY OF TEXAS AT AUSTIN C C THIS SUBROUTINE PERFORMS THE MAPPING OF POINTS IN THE C INTERVAL (0.,1.) ONTO A CURVE IN THE PLANE. THE SUBROUTINE C KURV1 SHOULD BE CALLED EARLIER TO DETERMINE CERTAIN C NECESSARY PARAMETERS. THE RESULTING CURVE HAS A PARAMETRIC C REPRESENTATION BOTH OF WHOSE COMPONENTS ARE SPLINES UNDER C TENSION AND FUNCTIONS OF THE POLYGONAL ARCLENGTH C PARAMETER. C C ON INPUT-- C C T CONTAINS A REAL VALUE TO BE MAPPED TO A POINT ON THE C CURVE. THE INTERVAL (0.,1.) IS MAPPED ONTO THE ENTIRE C CURVE, WITH 0. MAPPING TO (X(1),Y(1)) AND 1. MAPPING C TO (X(N),Y(N)). VALUES OUTSIDE THIS INTERVAL RESULT IN C EXTRAPOLATION. C C N CONTAINS THE NUMBER OF POINTS WHICH WERE SPECIFIED C TO DETERMINE THE CURVE. C C X AND Y ARE ARRAYS CONTAINING THE X- AND Y-COORDINATES C OF THE SPECIFIED POINTS. C C XP AND YP ARE THE ARRAYS OUTPUT FROM KURV1 CONTAINING C CURVATURE INFORMATION. C C S IS AN ARRAY CONTAINING THE POLYGONAL ARCLENGTHS OF C THE CURVE. C C AND C C SIGMA CONTAINS THE TENSION FACTOR (ITS SIGN IS IGNORED). C C THE PARAMETERS N, X, Y, XP, YP, S, AND SIGMA SHOULD BE C INPUT UNALTERED FROM THE OUTPUT OF KURV1. C C ON OUTPUT-- C C XS AND YS CONTAIN THE X- AND Y-COORDINATES OF THE IMAGE C POINT ON THE CURVE. C C NONE OF THE INPUT PARAMETERS ARE ALTERED. C C THIS SUBROUTINE REFERENCES PACKAGE MODULES INTRVL AND C SNHCSH. C C----------------------------------------------------------- C C DETERMINE INTERVAL C TN = S(N)*T IM1 = INTRVL(TN,S,N) I = IM1+1 C C DENORMALIZE TENSION FACTOR C SIGMAP = ABS(SIGMA)*FLOAT(N-1)/S(N) C C SET UP AND PERFORM INTERPOLATION C DEL1 = TN-S(IM1) DEL2 = S(I)-TN DELS = S(I)-S(IM1) SUMX = (X(I)*DEL1+X(IM1)*DEL2)/DELS SUMY = (Y(I)*DEL1+Y(IM1)*DEL2)/DELS IF (SIGMAP .NE. 0.) GO TO 1 D = DEL1*DEL2/(6.*DELS) C1 = (DEL1+DELS)*D C2 = (DEL2+DELS)*D XS = SUMX-XP(I)*C1-XP(IM1)*C2 YS = SUMY-YP(I)*C1-YP(IM1)*C2 RETURN 1 DELP1 = SIGMAP*(DEL1+DELS)/2. DELP2 = SIGMAP*(DEL2+DELS)/2. CALL SNHCSH(SINHM1,DUMMY,SIGMAP*DEL1,-1) CALL SNHCSH(SINHM2,DUMMY,SIGMAP*DEL2,-1) CALL SNHCSH(SINHMS,DUMMY,SIGMAP*DELS,-1) CALL SNHCSH (SINHP1,DUMMY,SIGMAP*DEL1/2.,-1) CALL SNHCSH (SINHP2,DUMMY,SIGMAP*DEL2/2.,-1) CALL SNHCSH (DUMMY,COSHP1,DELP1,1) CALL SNHCSH (DUMMY,COSHP2,DELP2,1) D = SIGMAP*SIGMAP*DELS*(SINHMS+SIGMAP*DELS) C1 = (SINHM1*DEL2-DEL1*(2.*(COSHP1+1.)*SINHP2+SIGMAP* * COSHP1*DEL2))/D C2 = (SINHM2*DEL1-DEL2*(2.*(COSHP2+1.)*SINHP1+SIGMAP* * COSHP2*DEL1))/D XS = SUMX+XP(I)*C1+XP(IM1)*C2 YS = SUMY+YP(I)*C1+YP(IM1)*C2 RETURN END SUBROUTINE KURVP1 (N,X,Y,XP,YP,TEMP,S,SIGMA,IERR) C INTEGER N,IERR REAL X(N),Y(N),XP(N),YP(N),TEMP(*),S(N),SIGMA C C FROM THE SPLINE UNDER TENSION PACKAGE C CODED BY A. K. CLINE AND R. J. RENKA C DEPARTMENT OF COMPUTER SCIENCES C UNIVERSITY OF TEXAS AT AUSTIN C C THIS SUBROUTINE DETERMINES THE PARAMETERS NECESSARY TO C COMPUTE A SPLINE UNDER TENSION FORMING A CLOSED CURVE IN C THE PLANE AND PASSING THROUGH A SEQUENCE OF PAIRS C (X(1),Y(1)),...,(X(N),Y(N)). FOR ACTUAL COMPUTATION OF C POINTS ON THE CURVE IT IS NECESSARY TO CALL THE SUBROUTINE C KURVP2. C C ON INPUT-- C C N IS THE NUMBER OF POINTS TO BE INTERPOLATED (N.GE.2). C C X IS AN ARRAY CONTAINING THE N X-COORDINATES OF THE C POINTS. C C Y IS AN ARRAY CONTAINING THE N Y-COORDINATES OF THE C POINTS. (ADJACENT X-Y PAIRS MUST BE DISTINCT, I. E. C EITHER X(I) .NE. X(I+1) OR Y(I) .NE. Y(I+1), FOR C I = 1,...,N-1.) C C XP AND YP ARE ARRAYS OF LENGTH AT LEAST N. C C TEMP IS AN ARRAY OF LENGTH AT LEAST 2*N WHICH IS USED C FOR SCRATCH STORAGE. C C S IS AN ARRAY OF LENGTH AT LEAST N. C C AND C C SIGMA CONTAINS THE TENSION FACTOR. THIS VALUE INDICATES C THE CURVINESS DESIRED. IF ABS(SIGMA) IS NEARLY ZERO C (E.G. .001) THE RESULTING CURVE IS APPROXIMATELY A CUBIC C SPLINE. IF ABS(SIGMA) IS LARGE (E. G. 50.) THE RESULTING C CURVE IS NEARLY A POLYGONAL LINE. IF SIGMA EQUALS ZERO A C CUBIC SPLINE RESULTS. A STANDARD VALUE FOR SIGMA IS C APPROXIMATELY 1. IN ABSOLUTE VALUE. C C ON OUTPUT-- C C XP AND YP CONTAIN INFORMATION ABOUT THE CURVATURE OF THE C CURVE AT THE GIVEN NODES. C C S CONTAINS THE POLYGONAL ARCLENGTHS OF THE CURVE. C C IERR CONTAINS AN ERROR FLAG, C = 0 FOR NORMAL RETURN, C = 1 IF N IS LESS THAN 2, C = 2 IF ADJACENT COORDINATE PAIRS COINCIDE. C C AND C C N, X, Y, AND SIGMA ARE UNALTERED, C C THIS SUBROUTINE REFERENCES PACKAGE MODULES TERMS AND C SNHCSH. C C----------------------------------------------------------- C NM1 = N-1 NP1 = N+1 IERR = 0 IF (N .LE. 1) GO TO 7 C C DETERMINE POLYGONAL ARCLENGTHS C S(1) = SQRT((X(N)-X(1))**2+(Y(N)-Y(1))**2) DO 1 I = 2,N IM1 = I-1 1 S(I) = S(IM1)+SQRT((X(I)-X(IM1))**2+ * (Y(I)-Y(IM1))**2) C C DENORMALIZE TENSION FACTOR C SIGMAP = ABS(SIGMA)*FLOAT(N)/S(N) C C SET UP RIGHT HAND SIDES OF TRIDIAGONAL (WITH CORNER C ELEMENTS) LINEAR SYSTEM FOR XP AND YP C DELS1 = S(1) IF (DELS1 .EQ. 0.) GO TO 8 DX1 = (X(1)-X(N))/DELS1 DY1 = (Y(1)-Y(N))/DELS1 CALL TERMS(DIAG1,SDIAG1,SIGMAP,DELS1) DELS2 = S(2)-S(1) IF (DELS2 .EQ. 0.) GO TO 8 DX2 = (X(2)-X(1))/DELS2 DY2 = (Y(2)-Y(1))/DELS2 CALL TERMS(DIAG2,SDIAG2,SIGMAP,DELS2) DIAG = DIAG1+DIAG2 DIAGIN = 1./DIAG XP(1) = (DX2-DX1)*DIAGIN YP(1) = (DY2-DY1)*DIAGIN TEMP(NP1) = -SDIAG1*DIAGIN TEMP(1) = SDIAG2*DIAGIN DX1 = DX2 DY1 = DY2 DIAG1 = DIAG2 SDIAG1 = SDIAG2 IF (N .EQ. 2) GO TO 3 DO 2 I = 2,NM1 NPI = N+I DELS2 = S(I+1)-S(I) IF (DELS2 .EQ. 0.) GO TO 8 DX2 = (X(I+1)-X(I))/DELS2 DY2 = (Y(I+1)-Y(I))/DELS2 CALL TERMS(DIAG2,SDIAG2,SIGMAP,DELS2) DIAG = DIAG1+DIAG2-SDIAG1*TEMP(I-1) DIAGIN = 1./DIAG XP(I) = (DX2-DX1-SDIAG1*XP(I-1))*DIAGIN YP(I) = (DY2-DY1-SDIAG1*YP(I-1))*DIAGIN TEMP(NPI) = -TEMP(NPI-1)*SDIAG1*DIAGIN TEMP(I) = SDIAG2*DIAGIN DX1 = DX2 DY1 = DY2 DIAG1 = DIAG2 2 SDIAG1 = SDIAG2 3 DELS2 = S(1) DX2 = (X(1)-X(N))/DELS2 DY2 = (Y(1)-Y(N))/DELS2 CALL TERMS(DIAG2,SDIAG2,SIGMAP,DELS2) XP(N) = DX2-DX1 YP(N) = DY2-DY1 TEMP(NM1) = TEMP(2*N-1)-TEMP(NM1) IF (N.EQ.2) GO TO 5 C C PERFORM FIRST STEP OF BACK SUBSTITUTION C DO 4 I = 3,N IBAK = NP1-I NPIBAK = N+IBAK XP(IBAK) = XP(IBAK)-TEMP(IBAK)*XP(IBAK+1) YP(IBAK) = YP(IBAK)-TEMP(IBAK)*YP(IBAK+1) 4 TEMP(IBAK) = TEMP(NPIBAK)-TEMP(IBAK)*TEMP(IBAK+1) 5 XP(N) = (XP(N)-SDIAG2*XP(1)-SDIAG1*XP(NM1))/ * (DIAG1+DIAG2+SDIAG2*TEMP(1)+SDIAG1*TEMP(NM1)) YP(N) = (YP(N)-SDIAG2*YP(1)-SDIAG1*YP(NM1))/ * (DIAG1+DIAG2+SDIAG2*TEMP(1)+SDIAG1*TEMP(NM1)) C C PERFORM SECOND STEP OF BACK SUBSTITUTION C XPN = XP(N) YPN = YP(N) DO 6 I = 1,NM1 XP(I) = XP(I)+TEMP(I)*XPN 6 YP(I) = YP(I)+TEMP(I)*YPN RETURN C C TOO FEW POINTS C 7 IERR = 1 RETURN C C COINCIDENT ADJACENT POINTS C 8 IERR = 2 RETURN END SUBROUTINE KURVP2 (T,XS,YS,N,X,Y,XP,YP,S,SIGMA) C INTEGER N REAL T,XS,YS,X(N),Y(N),XP(N),YP(N),S(N),SIGMA C C FROM THE SPLINE UNDER TENSION PACKAGE C CODED BY A. K. CLINE AND R. J. RENKA C DEPARTMENT OF COMPUTER SCIENCES C UNIVERSITY OF TEXAS AT AUSTIN C C THIS SUBROUTINE PERFORMS THE MAPPING OF POINTS IN THE C INTERVAL (0.,1.) ONTO A CLOSED CURVE IN THE PLANE. THE C SUBROUTINE KURVP1 SHOULD BE CALLED EARLIER TO DETERMINE C CERTAIN NECESSARY PARAMETERS. THE RESULTING CURVE HAS A C PARAMETRIC REPRESENTATION BOTH OF WHOSE COMPONENTS ARE C PERIODIC SPLINES UNDER TENSION AND FUNCTIONS OF THE POLY- C GONAL ARCLENGTH PARAMETER. C C ON INPUT-- C C T CONTAINS A VALUE TO BE MAPPED ONTO THE CURVE. THE C INTERVAL (0.,1.) IS MAPPED ONTO THE ENTIRE CLOSED CURVE C WITH BOTH 0. AND 1. MAPPING TO (X(1),Y(1)). THE MAPPING C IS PERIODIC WITH PERIOD ONE THUS ANY INTERVAL OF THE C FORM (TT,TT+1.) MAPS ONTO THE ENTIRE CURVE. C C N CONTAINS THE NUMBER OF POINTS WHICH WERE SPECIFIED C TO DETERMINE THE CURVE. C C X AND Y ARE ARRAYS CONTAINING THE X- AND Y-COORDINATES C OF THE SPECIFIED POINTS. C C XP AND YP ARE THE ARRAYS OUTPUT FROM KURVP1 CONTAINING C CURVATURE INFORMATION. C C S IS AN ARRAY CONTAINING THE POLYGONAL ARCLENGTHS OF C THE CURVE. C C AND C C SIGMA CONTAINS THE TENSION FACTOR (ITS SIGN IS IGNORED). C C THE PARAMETERS N, X, Y, XP, YP, S AND SIGMA SHOULD C BE INPUT UNALTERED FROM THE OUTPUT OF KURVP1. C C ON OUTPUT-- C C XS AND YS CONTAIN THE X- AND Y-COORDINATES OF THE IMAGE C POINT ON THE CURVE. C C NONE OF THE INPUT PARAMETERS ARE ALTERED. C C THIS SUBROUTINE REFERENCES PACKAGE MODULES INTRVL AND C SNHCSH. C C----------------------------------------------------------- C C DETERMINE INTERVAL C TN = T-FLOAT(IFIX(T)) IF (TN .LT. 0.) TN = TN+1. TN = S(N)*TN+S(1) IM1 = N IF (TN .LT. S(N)) IM1 = INTRVL(TN,S,N) I = IM1+1 IF (I .GT. N) I = 1 C C DENORMALIZE TENSION FACTOR C SIGMAP = ABS(SIGMA)*FLOAT(N)/S(N) C C SET UP AND PERFORM INTERPOLATION C SI = S(I) IF (IM1 .EQ. N) SI = S(N)+S(1) DEL1 = TN-S(IM1) DEL2 = SI-TN DELS = SI-S(IM1) SUMX = (X(I)*DEL1+X(IM1)*DEL2)/DELS SUMY = (Y(I)*DEL1+Y(IM1)*DEL2)/DELS IF (SIGMAP .NE. 0.) GO TO 1 D = DEL1*DEL2/(6.*DELS) C1 = (DEL1+DELS)*D C2 = (DEL2+DELS)*D XS = SUMX-XP(I)*C1-XP(IM1)*C2 YS = SUMY-YP(I)*C1-YP(IM1)*C2 RETURN 1 DELP1 = SIGMAP*(DEL1+DELS)/2. DELP2 = SIGMAP*(DEL2+DELS)/2. CALL SNHCSH(SINHM1,DUMMY,SIGMAP*DEL1,-1) CALL SNHCSH(SINHM2,DUMMY,SIGMAP*DEL2,-1) CALL SNHCSH(SINHMS,DUMMY,SIGMAP*DELS,-1) CALL SNHCSH (SINHP1,DUMMY,SIGMAP*DEL1/2.,-1) CALL SNHCSH (SINHP2,DUMMY,SIGMAP*DEL2/2.,-1) CALL SNHCSH (DUMMY,COSHP1,DELP1,1) CALL SNHCSH (DUMMY,COSHP2,DELP2,1) D = SIGMAP*SIGMAP*DELS*(SINHMS+SIGMAP*DELS) CI = (SINHM1*DEL2-DEL1*(2.*(COSHP1+1.)*SINHP2+SIGMAP* * COSHP1*DEL2))/D CIM1 = (SINHM2*DEL1-DEL2*(2.*(COSHP2+1.)*SINHP1+ * SIGMAP*COSHP2*DEL1))/D XS = SUMX+CI*XP(I)+CIM1*XP(IM1) YS = SUMY+CI*YP(I)+CIM1*YP(IM1) RETURN END SUBROUTINE QURV1 (N,X,Y,Z,SLP1X,SLP1Y,SLP1Z,SLPNX, * SLPNY,SLPNZ,ISLPSW,XP,YP,ZP,TEMP, * S,SIGMA,IERR) C INTEGER N,ISLPSW,IERR REAL X(N),Y(N),Z(N),SLP1X,SLP1Y,SLP1Z,SLPNX,SLPNY, * SLPNZ,XP(N),YP(N),ZP(N),TEMP(N),S(N),SIGMA C C FROM THE SPLINE UNDER TENSION PACKAGE C CODED BY A. K. CLINE AND R. J. RENKA C DEPARTMENT OF COMPUTER SCIENCES C UNIVERSITY OF TEXAS AT AUSTIN C C THIS SUBROUTINE DETERMINES THE PARAMETERS NECESSARY TO C COMPUTE A SPLINE UNDER TENSION PASSING THROUGH A SEQUENCE C OF TRIPLES (X(1),Y(1),Z(1)),...,(X(N),Y(N),Z(N)). THE C SLOPES AT THE TWO ENDS OF THE CURVE MAY BE SPECIFIED OR C OMITTED. FOR ACTUAL COMPUTATION OF POINTS ON THE CURVE C IT IS NECESSARY TO CALL THE SUBROUTINE QURV2. C C ON INPUT-- C C N IS THE NUMBER OF POINTS TO BE INTERPOLATED (N.GE.2). C C X IS AN ARRAY CONTAINING THE N X-COORDINATES OF THE C POINTS. C C Y IS AN ARRAY CONTAINING THE N Y-COORDINATES OF THE C POINTS. C C Z IS AN ARRAY CONTAINING THE N Z-COORDINATES OF THE C POINTS. (ADJACENT X-Y-Z TRIPLES MUST BE DISTINCT, I. E. C EITHER X(I) .NE. X(I+1) OR Y(I) .NE. Y(I+1) OR Z(I) .NE. C Z(I+1), FOR I = 1,...,N-1 ). C C SLP1X, SLP1Y, SLP1Z AND SLPNX, SLPNY, SLPNZ CONTAIN THE C DESIRED VALUES OF THE COMPONENTS OF TANGENT VECTORS TO C THE CURVE AT (X(1),Y(1),Z(1)) AND(X(N),Y(N),Z(N)), C RESPECTIVELY. THE POSITIVE SENSE OF THE CURVE IS ASSUMED C TO BE THAT MOVING FROM POINT 1 TO POINT N. THE USER MAY C OMIT VALUES FOR EITHER OR BOTH OF THESE TRIPLES AND C SIGNAL THIS WITH ISLPSW. C C ISLPSW CONTAINS A SWITCH INDICATING WHICH SLOPE DATA C SHOULD BE USED AND WHICH SHOULD BE ESTIMATED BY THIS C SUBROUTINE, C = 0 IF SLP1X, SLP1Y, SLP1Z AND SLPNX, SLPNY, C SLPNZ ARE TO BE USED, C = 1 IF SLP1X, SLP1Y, SLP1Z ARE TO BE USED BUT C NOT SLPNX, SLPNY, SLPNZ, C = 2 IF SLPNX, SLPNY, SLPNZ ARE TO BE USED BUT C NOT SLP1X, SLP1Y, SLP1Z, C = 3 IF BOTH END-TANGENTS ARE TO BE ESTIMATED C INTERNALLY. C C XP, YP, AND ZP ARE ARRAYS OF LENGTH AT LEAST N. C C TEMP IS AN ARRAY OF LENGTH AT LEAST N WHICH IS USED C FOR SCRATCH STORAGE. C C S IS AN ARRAY OF LENGTH AT LEAST N. C C AND C C SIGMA CONTAINS THE TENSION FACTOR. THIS VALUE INDICATES C THE CURVINESS DESIRED. IF ABS(SIGMA) IS NEARLY ZERO C (E.G. .001) THE RESULTING CURVE IS APPROXIMATELY A CUBIC C SPLINE. IF ABS(SIGMA) IS LARGE (E. G. 50.) THE RESULTING C CURVE IS NEARLY A POLYGONAL LINE. IF SIGMA EQUALS ZERO A C CUBIC SPLINE RESULTS. A STANDARD VALUE FOR SIGMA IS C APPROXIMATELY 1. IN ABSOLUTE VALUE. C C ON OUTPUT-- C C XP, YP, AND ZP CONTAIN INFORMATION ABOUT THE CURVATURE C OF THE CURVE AT THE GIVEN NODES. C C S CONTAINS THE POLYGONAL ARCLENGTHS OF THE CURVE. C C IERR CONTAINS AN ERROR FLAG, C = 0 FOR NORMAL RETURN, C = 1 IF N IS LESS THAN 2, C = 2 IF ADJACENT TRIPLES COINCIDE. C C AND C C N, X, Y, Z, SLP1X, SLP1Y, SLP1Z, SLPNX, SLPNY, SLPNZ, C ISLPSW, AND SIGMA ARE UNALTERED, C C THIS SUBROUTINE REFERENCES PACKAGE MODULES CEEZ, TERMS, C AND SNHCSH. C C----------------------------------------------------------- C NM1 = N-1 NP1 = N+1 IERR = 0 IF (N .LE. 1) GO TO 9 C C DETERMINE POLYGONAL ARCLENGTHS C S(1) = 0. DO 1 I = 2,N IM1 = I-1 1 S(I) = S(IM1)+SQRT((X(I)-X(IM1))**2+(Y(I)-Y(IM1))**2 * +(Z(I)-Z(IM1))**2) C C DENORMALIZE TENSION FACTOR C SIGMAP = ABS(SIGMA)*FLOAT(N-1)/S(N) C C APPROXIMATE END SLOPES C IF (ISLPSW .GE. 2) GO TO 2 SLPP1X = SLP1X SLPP1Y = SLP1Y SLPP1Z = SLP1Z GO TO 3 2 DELS1 = S(2)-S(1) DELS2 = DELS1+DELS1 IF (N .GT. 2) DELS2 = S(3)-S(1) IF (DELS1 .EQ. 0. .OR. DELS2 .EQ. 0.) GO TO 9 CALL CEEZ (DELS1,DELS2,SIGMAP,C1,C2,C3,N) SLPP1X = C1*X(1)+C2*X(2) SLPP1Y = C1*Y(1)+C2*Y(2) SLPP1Z = C1*Z(1)+C2*Z(2) IF (N .EQ. 2) GO TO 3 SLPP1X = SLPP1X+C3*X(3) SLPP1Y = SLPP1Y+C3*Y(3) SLPP1Z = SLPP1Z+C3*Z(3) 3 DELT = SQRT(SLPP1X*SLPP1X+SLPP1Y*SLPP1Y+SLPP1Z*SLPP1Z) SLPP1X = SLPP1X/DELT SLPP1Y = SLPP1Y/DELT SLPP1Z = SLPP1Z/DELT IF (ISLPSW .EQ. 1 .OR. ISLPSW .EQ. 3) GO TO 4 SLPPNX = SLPNX SLPPNY = SLPNY SLPPNZ = SLPNZ GO TO 5 4 DELSN = S(N)-S(NM1) DELSNM = DELSN+DELSN IF (N .GT. 2) DELSNM = S(N)-S(N-2) IF (DELSN .EQ. 0. .OR. DELSNM .EQ. 0.) GO TO 10 CALL CEEZ (-DELSN,-DELSNM,SIGMAP,C1,C2,C3,N) SLPPNX = C1*X(N)+C2*X(NM1) SLPPNY = C1*Y(N)+C2*Y(NM1) SLPPNZ = C1*Z(N)+C2*Z(NM1) IF (N .EQ. 2) GO TO 5 SLPPNX = SLPPNX+C3*X(N-2) SLPPNY = SLPPNY+C3*Y(N-2) SLPPNZ = SLPPNZ+C3*Z(N-2) 5 DELT = SQRT(SLPPNX*SLPPNX+SLPPNY*SLPPNY+SLPPNZ*SLPPNZ) SLPPNX = SLPPNX/DELT SLPPNY = SLPPNY/DELT SLPPNZ = SLPPNZ/DELT C C SET UP RIGHT HAND SIDES AND TRIDIAGONAL SYSTEM FOR XP, YP C AND ZP AND PERFORM FORWARD ELIMINATION C DX1 = (X(2)-X(1))/S(2) DY1 = (Y(2)-Y(1))/S(2) DZ1 = (Z(2)-Z(1))/S(2) CALL TERMS (DIAG1,SDIAG1,SIGMAP,S(2)) XP(1) = (DX1-SLPP1X)/DIAG1 YP(1) = (DY1-SLPP1Y)/DIAG1 ZP(1) = (DZ1-SLPP1Z)/DIAG1 TEMP(1) = SDIAG1/DIAG1 IF (N .EQ. 2) GO TO 7 DO 6 I = 2,NM1 DELS2 = S(I+1)-S(I) IF (DELS2 .EQ. 0.) GO TO 10 DX2 = (X(I+1)-X(I))/DELS2 DY2 = (Y(I+1)-Y(I))/DELS2 DZ2 = (Z(I+1)-Z(I))/DELS2 CALL TERMS (DIAG2,SDIAG2,SIGMAP,DELS2) DIAG = DIAG1+DIAG2-SDIAG1*TEMP(I-1) DIAGIN = 1./DIAG XP(I) = (DX2-DX1-SDIAG1*XP(I-1))*DIAGIN YP(I) = (DY2-DY1-SDIAG1*YP(I-1))*DIAGIN ZP(I) = (DZ2-DZ1-SDIAG1*ZP(I-1))*DIAGIN TEMP(I) = SDIAG2*DIAGIN DX1 = DX2 DY1 = DY2 DZ1 = DZ2 DIAG1 = DIAG2 6 SDIAG1 = SDIAG2 7 DIAG = DIAG1-SDIAG1*TEMP(NM1) XP(N) = (SLPPNX-DX1-SDIAG1*XP(NM1))/DIAG YP(N) = (SLPPNY-DY1-SDIAG1*YP(NM1))/DIAG ZP(N) = (SLPPNZ-DZ1-SDIAG1*ZP(NM1))/DIAG C C PERFORM BACK SUBSTITUTION C DO 8 I = 2,N IBAK = NP1-I T = TEMP(IBAK) XP(IBAK) = XP(IBAK)-T*XP(IBAK+1) YP(IBAK) = YP(IBAK)-T*YP(IBAK+1) 8 ZP(IBAK) = ZP(IBAK)-T*ZP(IBAK+1) RETURN C C TOO FEW POINTS C 9 IERR = 1 RETURN C C COINCIDENT ADJACENT POINTS C 10 IERR = 2 RETURN END SUBROUTINE QURV2 (T,XS,YS,ZS,N,X,Y,Z,XP,YP,ZP,S,SIGMA) C INTEGER N REAL T,XS,YS,ZS,X(N),Y(N),Z(N),XP(N),YP(N),ZP(N),S(N) REAL SIGMA C C FROM THE SPLINE UNDER TENSION PACKAGE C CODED BY A. K. CLINE AND R. J. RENKA C DEPARTMENT OF COMPUTER SCIENCES C UNIVERSITY OF TEXAS AT AUSTIN C C THIS SUBROUTINE PERFORMS THE MAPPING OF POINTS IN THE C INTERVAL (0.,1.) ONTO A CURVE IN SPACE. THE SUBROUTINE C QURV1 SHOULD BE CALLED EARLIER TO DETERMINE CERTAIN C NECESSARY PARAMETERS. THE RESULTING CURVE HAS A PARAMETRIC C REPRESENTATION ALL OF WHOSE COMPONENTS ARE SPLINES UNDER C TENSION AND FUNCTIONS OF THE POLYGONAL ARCLENGTH C PARAMETER. C C ON INPUT-- C C T CONTAINS A REAL VALUE TO BE MAPPED TO A POINT ON THE C CURVE. THE INTERVAL (0.,1.) IS MAPPED ONTO THE ENTIRE C CURVE, WITH 0. MAPPING TO (X(1),Y(1,Z(1)) AND 1. MAPPING C TO (X(N),Y(N),Z(N)). VALUES OUTSIDE THIS INTERVAL RESULT C IN EXTRAPOLATION. C C N CONTAINS THE NUMBER OF POINTS WHICH WERE SPECIFIED C TO DETERMINE THE CURVE. C C X, Y, AND Z ARE ARRAYS CONTAINING THE X-, Y- AND Z- C COORDINATES OF THE SPECIFIED POINTS. C C XP, YP, AND ZP ARE THE ARRAYS OUTPUT FROM QURV1 C CONTAINING CURVATURE INFORMATION. C C S IS AN ARRAY CONTAINING THE POLYGONAL ARCLENGTHS OF C THE CURVE. C C AND C C SIGMA CONTAINS THE TENSION FACTOR (ITS SIGN IS IGNORED). C C THE PARAMETERS N, X, Y, Z, XP, YP, ZP, S, AND SIGMA C SHOULD BE INPUT UNALTERED FROM THE OUTPUT OF QURV1. C C ON OUTPUT-- C C XS, YS AND ZS CONTAIN THE X-, Y- AND Z-COORDINATES OF C THE IMAGE POINT ON THE CURVE. C C NONE OF THE INPUT PARAMETERS ARE ALTERED. C C THIS SUBROUTINE REFERENCES PACKAGE MODULES INTRVL AND C SNHCSH. C C----------------------------------------------------------- C C DETERMINE INTERVAL C TN = S(N)*T IM1 = INTRVL(TN,S,N) I = IM1+1 C C DENORMALIZE TENSION FACTOR C SIGMAP = ABS(SIGMA)*FLOAT(N-1)/S(N) C C SET UP AND PERFORM INTERPOLATION C DEL1 = TN-S(IM1) DEL2 = S(I)-TN DELS = S(I)-S(IM1) SUMX = (X(I)*DEL1+X(IM1)*DEL2)/DELS SUMY = (Y(I)*DEL1+Y(IM1)*DEL2)/DELS SUMZ = (Z(I)*DEL1+Z(IM1)*DEL2)/DELS IF (SIGMAP .NE. 0.) GO TO 1 D = DEL1*DEL2/(6.*DELS) C1 = (DEL1+DELS)*D C2 = (DEL2+DELS)*D XS = SUMX-XP(I)*C1-XP(IM1)*C2 YS = SUMY-YP(I)*C1-YP(IM1)*C2 ZS = SUMZ-ZP(I)*C1-ZP(IM1)*C2 RETURN 1 DELP1 = SIGMAP*(DEL1+DELS)/2. DELP2 = SIGMAP*(DEL2+DELS)/2. CALL SNHCSH(SINHM1,DUMMY,SIGMAP*DEL1,-1) CALL SNHCSH(SINHM2,DUMMY,SIGMAP*DEL2,-1) CALL SNHCSH(SINHMS,DUMMY,SIGMAP*DELS,-1) CALL SNHCSH (SINHP1,DUMMY,SIGMAP*DEL1/2.,-1) CALL SNHCSH (SINHP2,DUMMY,SIGMAP*DEL2/2.,-1) CALL SNHCSH (DUMMY,COSHP1,DELP1,1) CALL SNHCSH (DUMMY,COSHP2,DELP2,1) D = SIGMAP*SIGMAP*DELS*(SINHMS+SIGMAP*DELS) C1 = (SINHM1*DEL2-DEL1*(2.*(COSHP1+1.)*SINHP2+SIGMAP* * COSHP1*DEL2))/D C2 = (SINHM2*DEL1-DEL2*(2.*(COSHP2+1.)*SINHP1+SIGMAP* * COSHP2*DEL1))/D XS = SUMX+XP(I)*C1+XP(IM1)*C2 YS = SUMY+YP(I)*C1+YP(IM1)*C2 ZS = SUMZ+ZP(I)*C1+ZP(IM1)*C2 RETURN END SUBROUTINE CEEZ (DEL1,DEL2,SIGMA,C1,C2,C3,N) C REAL DEL1,DEL2,SIGMA,C1,C2,C3 C C FROM THE SPLINE UNDER TENSION PACKAGE C CODED BY A. K. CLINE AND R. J. RENKA C DEPARTMENT OF COMPUTER SCIENCES C UNIVERSITY OF TEXAS AT AUSTIN C C THIS SUBROUTINE DETERMINES THE COEFFICIENTS C1, C2, AND C3 C USED TO DETERMINE ENDPOINT SLOPES. SPECIFICALLY, IF C FUNCTION VALUES Y1, Y2, AND Y3 ARE GIVEN AT POINTS X1, X2, C AND X3, RESPECTIVELY, THE QUANTITY C1*Y1 + C2*Y2 + C3*Y3 C IS THE VALUE OF THE DERIVATIVE AT X1 OF A SPLINE UNDER C TENSION (WITH TENSION FACTOR SIGMA) PASSING THROUGH THE C THREE POINTS AND HAVING THIRD DERIVATIVE EQUAL TO ZERO AT C X1. OPTIONALLY, ONLY TWO VALUES, C1 AND C2 ARE DETERMINED. C C ON INPUT-- C C DEL1 IS X2-X1 (.GT. 0.). C C DEL2 IS X3-X1 (.GT. 0.). IF N .EQ. 2, THIS PARAMETER IS C IGNORED. C C SIGMA IS THE TENSION FACTOR. C C AND C C N IS A SWITCH INDICATING THE NUMBER OF COEFFICIENTS TO C BE RETURNED. IF N .EQ. 2 ONLY TWO COEFFICIENTS ARE C RETURNED. OTHERWISE ALL THREE ARE RETURNED. C C ON OUTPUT-- C C C1, C2, AND C3 CONTAIN THE COEFFICIENTS. C C NONE OF THE INPUT PARAMETERS ARE ALTERED. C C THIS SUBROUTINE REFERENCES PACKAGE MODULE SNHCSH. C C----------------------------------------------------------- C IF (N .EQ. 2) GO TO 2 IF (SIGMA .NE. 0.) GO TO 1 DEL = DEL2-DEL1 C C TENSION .EQ. 0. C C1 = -(DEL1+DEL2)/(DEL1*DEL2) C2 = DEL2/(DEL1*DEL) C3 = -DEL1/(DEL2*DEL) RETURN C C TENSION .NE. 0. C 1 CALL SNHCSH (DUMMY,COSHM1,SIGMA*DEL1,1) CALL SNHCSH (DUMMY,COSHM2,SIGMA*DEL2,1) DELP = SIGMA*(DEL2+DEL1)/2. DELM = SIGMA*(DEL2-DEL1)/2. CALL SNHCSH (SINHMP,DUMMY,DELP,-1) CALL SNHCSH (SINHMM,DUMMY,DELM,-1) DENOM = COSHM1*(DEL2-DEL1)-2.*DEL1*(SINHMP+DELP)* * (SINHMM+DELM) C1 = 2.*(SINHMP+DELP)*(SINHMM+DELM)/DENOM C2 = -COSHM2/DENOM C3 = COSHM1/DENOM RETURN C C TWO COEFFICIENTS C 2 C1 = -1./DEL1 C2 = -C1 RETURN END SUBROUTINE TERMS (DIAG,SDIAG,SIGMA,DEL) C REAL DIAG,SDIAG,SIGMA,DEL C C FROM THE SPLINE UNDER TENSION PACKAGE C CODED BY A. K. CLINE AND R. J. RENKA C DEPARTMENT OF COMPUTER SCIENCES C UNIVERSITY OF TEXAS AT AUSTIN C C THIS SUBROUTINE COMPUTES THE DIAGONAL AND SUPERDIAGONAL C TERMS OF THE TRIDIAGONAL LINEAR SYSTEM ASSOCIATED WITH C SPLINE UNDER TENSION INTERPOLATION. C C ON INPUT-- C C SIGMA CONTAINS THE TENSION FACTOR. C C AND C C DEL CONTAINS THE STEP SIZE. C C ON OUTPUT-- C C (SIGMA*DEL*COSH(SIGMA*DEL) - SINH(SIGMA*DEL) C DIAG = DEL*--------------------------------------------. C (SIGMA*DEL)**2 * SINH(SIGMA*DEL) C C SINH(SIGMA*DEL) - SIGMA*DEL C SDIAG = DEL*----------------------------------. C (SIGMA*DEL)**2 * SINH(SIGMA*DEL) C C AND C C SIGMA AND DEL ARE UNALTERED. C C THIS SUBROUTINE REFERENCES PACKAGE MODULE SNHCSH. C C----------------------------------------------------------- C IF (SIGMA .NE. 0.) GO TO 1 DIAG = DEL/3. SDIAG = DEL/6. RETURN 1 SIGDEL = SIGMA*DEL CALL SNHCSH (SINHM,COSHM,SIGDEL,0) DENOM = DEL/((SINHM+SIGDEL)*SIGDEL*SIGDEL) DIAG = DENOM*(SIGDEL*COSHM-SINHM) SDIAG = DENOM*SINHM RETURN END INTEGER FUNCTION INTRVL (X, T, M) REAL X, T(M) C----------------------------------------------------------------------- C C LOCATION OF A VALUE X IN A SEQUENCE T C C ---------------- C C INPUT-- C C X IS A REAL NUMBER. C C T IS AN ARRAY OF NONDECREASING VALUES. IT IS C ASSUMED THAT T(1) .LT. T(M). C C M IS THE LENGTH OF T (M .GE. 2). C C OUTPUT-- C C INTRVL HAS THE VALUE I WHEN T(I) .LE. X .LT. T(I+1). C OTHERWISE, IF L IS THE INTEGER WHERE T(L) .LT. T(L+1) C AND T(L+1) = ... = T(M), THEN INTRVL HAS THE VALUE I C WHERE C I = 1 IF X .LT. T(1) C I = L IF X .GE. T(L) C C----------------------------------------------------------------------- IF (X .LT. T(2)) GO TO 100 TM = T(M) I = M - 1 10 IF (T(I) .LT. TM) GO TO 20 I = I - 1 GO TO 10 20 IF (X .GE. T(I)) GO TO 110 IL = 2 IR = I C C BISECTION SEARCH C 30 I = (IL + IR)/2 IF (I .EQ. IL) GO TO 110 IF (X - T(I)) 40,60,50 40 IR = I GO TO 30 50 IL = I GO TO 30 C C CASE WHEN X = T(I) FOR SOME I C 60 IF (X .LT. T(I+1)) GO TO 110 I = I + 1 GO TO 60 C C LEFT END C 100 INTRVL = 1 RETURN C C NORMAL EXIT C 110 INTRVL = I RETURN END SUBROUTINE BVAL (T, BCOEF, N, K, X, JDERIV, W, WK) C----------------------------------------------------------------------- C C BVAL CALCULATES THE VALUE AT X OF THE JDERIV-TH DERIVATIVE C OF A SPLINE F FROM ITS B-REPRESENTATION. C C****** I N P U T ****** C C T AN ARRAY OF DIMENSION N + K CONTAING THE KNOTS OF THE C SPLINE. IT IS ASSUMED THAT T(I) .LE. T(I+1) FOR EACH I. C BCOEF AN ARRAY OF DIMENSION N CONTAINING THE B-COEFFICIENTS C OF THE SPLINE F. C N LENGTH OF BCOEF (N .GE. 1). C K ORDER OF THE SPLINE. C X THE POINT AT WHICH TO EVALUATE. C JDERIV INTEGER GIVING THE ORDER OF THE DERIVATIVE TO BE C EVALUATED. IT IS ASSUMED THAT JDERIV .GE. 0. C C****** O U T P U T ****** C C W THE VALUE OF THE (JDERIV)-TH DERIVATIVE OF F AT X. C C****** W O R K S P A C E ****** C C WK AN ARRAY OF DIMENSION 3*K OR LARGER. C C****** M E T H O D ****** C C THE NONTRIVIAL KNOT INTERVAL (T(I),T(I+1)) CONTAINING X IS FIRST C OBTAINED. THEN THE K B-COEFFICIENTS OF F RELEVANT FOR THIS INTERVAL C ARE OBTAINED FROM BCOEF (OR TAKEN TO BE ZERO IF NOT EXPLICITLY AVAIL- C ABLE), AND DIFFERENCED JDERIV TIMES TO OBTAIN THE B-COEFFICIENTS OF C (D**JDERIV)F RELEVANT FOR THE INTERVAL. SPECIFICALLY, IF J = JDERIV C THEN FROM X.(12) OF THE REFERENCE WE HAVE C C (D**J)F = SUM ( BCOEF(.,J)*B(.,K-J,T) ) C C WHERE C / BCOEF(.), , J .EQ. 0 C / C BCOEF(.,J) = / BCOEF(.,J-1) - BCOEF(.-1,J-1) C / ----------------------------- , J .GT. 0 C / (T(.+K-J) - T(.))/(K-J) C C THEN, WE USE REPEATEDLY THE FACT THAT C C SUM ( A(.)*B(.,M,T)(X) ) = SUM ( A(.,X)*B(.,M-1,T)(X) ) C WITH C (X - T(.))*A(.) + (T(.+M-1) - X)*A(.-1) C A(.,X) = --------------------------------------- C (X - T(.)) + (T(.+M-1) - X) C C TO WRITE (D**J)F(X) EVENTUALLY AS A LINEAR COMBINATION OF B-SPLINES C OF ORDER 1. THE COEFFICIENT FOR B(I,1,T)(X) MUST THEN BE THE DESIRED C NUMBER (D**J)F(X). (SEE X.(17)-(19) OF THE REFERENCE). C C----------------------------------------------------------------------- C REFERENCE. DE BOOR, CARL, A PRATICAL GUIDE TO SPLINES, SPRINGER- C VERLAG, NEW YORK, 1978. C----------------------------------------------------------------------- REAL T(*), BCOEF(N), WK(K,3) C W = 0.0 IF (JDERIV .GE. K) RETURN C C *** FIND I WHERE 1 .LE. I .LT. N+K AND T(I) .LE. X .LT. T(I+1). C IF NO SUCH I EXISTS, THEN X LIES OUTSIDE THE SUPPORT OF THE C SPLINE F AND W = 0. C NPK = N + K IF (X .LT. T(1) .OR. X .GT. T(NPK)) RETURN I = INTRVL(X, T, NPK) C C *** IF K = 1 (AND JDERIV = 0), W = BCOEF(I). C KM1 = K - 1 IF (KM1 .GT. 0) GO TO 10 W = BCOEF(I) RETURN C C *** STORE THE K B-SPLINE COEFFICIENTS RELEVANT FOR THE KNOT INTERVAL C (T(I),T(I+1)) IN THE FIRST COLUMN OF WK AND COMPUTE WK(J,2) = C X - T(I+1-J), WK(J,3) = T(I+J) - X, J=1,...,K-1 . SET ANY OF THE C WK(J,1) NOT OBTAINABLE FROM INPUT TO ZERO. SET ANY T.S NOT OBTAIN- C ABLE EQUAL TO T(1) OR TO T(N+K) APPROPRIATELY. C 10 JCMIN = 1 IMK = I - K IF (IMK .GE. 0) GO TO 40 C JCMIN = 1 - IMK L = I DO 20 J = 1,I WK(J,2) = X - T(L) L = L - 1 20 CONTINUE DO 30 J = I,KM1 L = K - J WK(L,1) = 0.0 WK(J,2) = WK(I,2) 30 CONTINUE GO TO 60 C 40 L = I DO 50 J = 1,KM1 WK(J,2) = X - T(L) L = L - 1 50 CONTINUE C 60 JCMAX = K NMI = N - I IF (NMI .GE. 0) GO TO 100 C JCMAX = K + NMI DO 70 J = 1,JCMAX IPJ = I + J WK(J,3) = T(IPJ) - X 70 CONTINUE DO 80 J = JCMAX,KM1 WK(J+1,1) = 0.0 WK(J,3) = WK(JCMAX,3) 80 CONTINUE GO TO 120 C 100 DO 110 J = 1,KM1 IPJ = I + J WK(J,3) = T(IPJ) - X 110 CONTINUE C 120 DO 130 JC = JCMIN,JCMAX L = IMK + JC WK(JC,1) = BCOEF(L) 130 CONTINUE C C *** DIFFERENCE THE COEFFICIENTS JDERIV TIMES. C IF (JDERIV .EQ. 0) GO TO 170 DO 160 J = 1,JDERIV KMJ = K - J FKMJ = KMJ L = KMJ DO 150 JJ = 1,KMJ DL = WK(L,2) DR = WK(JJ,3) WK(JJ,1) = ((WK(JJ+1,1) - WK(JJ,1))/(DL + DR))*FKMJ 150 L = L - 1 160 CONTINUE C C *** COMPUTE VALUE AT X IN (T(I),T(I+1)) OF JDERIV-TH DERIVATIVE, C GIVEN ITS RELEVANT B-SPLINE COEFFS IN WK(1,1),...,WK(K-JDERIV,1). C 170 IF (JDERIV .EQ. KM1) GO TO 200 JDRVP1 = JDERIV + 1 DO 190 J = JDRVP1,KM1 KMJ = K - J L = KMJ DO 180 JJ = 1,KMJ DL = WK(L,2) DR = WK(JJ,3) WK(JJ,1) = (WK(JJ+1,1)*DL + WK(JJ,1)*DR)/(DL + DR) 180 L = L - 1 190 CONTINUE C 200 W = WK(1,1) RETURN END SUBROUTINE BVALI (T, BCOEFF, N, K, X, W, WK) C----------------------------------------------------------------------- C INTEGRAL OF A PIECEWISE POLYNOMIAL FROM T(1) TO X C USING ITS B-SPLINE REPRESENTATION C----------------------------------------------------------------------- C REAL T(N + K), WK(N + 3*(K + 1)) C--------------------------- REAL T(*), BCOEFF(N), WK(*) C W = 0.0 IF (X .LE. T(1)) RETURN NPK = N + K TLAST = T(NPK) XVAL = AMIN1(X, TLAST) C C DEFINE THE FIRST NEW KNOT. THE REMAINING NEW KNOTS C ARE ASSUMED TO BE THE SAME AS THIS KNOT. C TNEW = 0.1 IF (TLAST .LT. -0.1) TNEW = 0.9*TLAST IF (TLAST .GT. 0.0) TNEW = 1.1*TLAST C C COMPUTE THE FIRST N COEFFICIENTS OF THE ANTIDERIVATIVE C SUM = 0.0 DO 10 I = 1,N IPK = I + K SUM = SUM + BCOEFF(I)*(T(IPK) - T(I)) WK(I) = SUM/K 10 CONTINUE C C COMPUTE THE ANTIDERIVATIVE C KP1 = K + 1 NP1 = N + 1 CALL BVALI0 (T, TNEW, WK(1), N, KP1, XVAL, W, WK(NP1)) RETURN END SUBROUTINE BVALI0 (T, TNEW, BCOEF, N, K, X, W, WK) C----------------------------------------------------------------------- C C BVALI0 CALCULATES THE VALUE AT X OF AN ANTIDERIVATIVE C OF A B-SPLINE F FOR T(1) .LE. X .LE. T(N + K - 1). C C****** I N P U T ****** C C T AN ARRAY CONTAINING THE FIRST N + K - 1 KNOTS OF THE C ANTIDERIVATIVE. C TNEW THE REMAING KNOTS ARE ALL LOCATED AT THIS POINT. C BCOEF AN ARRAY CONTAINING THE FIRST N COEFFICIENTS OF THE C ANTIDERIVATIVE. C N LENGTH OF BCOEF (N .GE. 1). C K ORDER OF THE ANTIDERIVATIVE. C X THE POINT AT WHICH TO EVALUATE. C C****** O U T P U T ****** C C W THE VALUE OF THE ANTIDERIVATIVE AT X. C C****** W O R K S P A C E ****** C C WK AN ARRAY OF DIMENSION 3*K OR LARGER. C C----------------------------------------------------------------------- C REMARK. BVALI0 IS AN ADAPTATION BY A.H. MORRIS (NSWC) OF THE C SUBROUTINE BVAL. C----------------------------------------------------------------------- REAL T(*), BCOEF(N), WK(K,3) C W = 0.0 KM1 = K - 1 M = N + KM1 I = INTRVL(X, T, M) C C *** STORE THE K B-SPLINE COEFFICIENTS RELEVANT FOR THE KNOT INTERVAL C (T(I),T(I+1)) IN THE FIRST COLUMN OF WK AND COMPUTE WK(J,2) = C X - T(I+1-J), WK(J,3) = T(I+J) - X, J=1,...,K-1 . SET ANY OF THE C WK(J,1) NOT OBTAINABLE FROM INPUT TO ZERO. SET ANY T.S NOT OBTAIN- C ABLE EQUAL TO T(1) OR TNEW APPROPRIATELY. C JCMIN = 1 IMK = I - K IF (IMK .GE. 0) GO TO 30 C JCMIN = 1 - IMK L = I DO 10 J = 1,I WK(J,2) = X - T(L) L = L - 1 10 CONTINUE DO 20 J = I,KM1 L = K - J WK(L,1) = 0.0 WK(J,2) = WK(I,2) 20 CONTINUE GO TO 50 C 30 L = I DO 40 J = 1,KM1 WK(J,2) = X - T(L) L = L - 1 40 CONTINUE C 50 DO 60 J = 1,KM1 TIPJ = TNEW IPJ = I + J IF (IPJ .LE. M) TIPJ = T(IPJ) WK(J,3) = TIPJ - X 60 CONTINUE C DO 70 JC = JCMIN,K L = MIN0(IMK + JC, N) WK(JC,1) = BCOEF(L) 70 CONTINUE C C *** COMPUTE VALUE AT X IN (T(I),T(I+1)), GIVEN ITS RELEVANT C B-SPLINE COEFFS IN WK(1,1),...,WK(K,1). C DO 110 J = 1,KM1 KMJ = K - J L = KMJ DO 100 JJ = 1,KMJ DL = WK(L,2) DR = WK(JJ,3) WK(JJ,1) = (WK(JJ+1,1)*DL + WK(JJ,1)*DR)/(DL + DR) 100 L = L - 1 110 CONTINUE C W = WK(1,1) RETURN END SUBROUTINE BSPP (T, A, N, K, BREAK, C, L, WK) C----------------------------------------------------------------------- C C CONVERSION FROM B-SPLINE REPRESENTATION C TO PIECEWISE POLYNOMIAL REPRESENTATION C C C INPUT ... C C T KNOT SEQUENCE OF LENGTH N+K C A B-SPLINE COEFFICIENT SEQUENCE OF LENGTH N C N LENGTH OF A C K ORDER OF THE B-SPLINES C C OUTPUT ... C C BREAK BREAKPOINT SEQUENCE, OF LENGTH L+1, CONTAINING C (IN INCREASING ORDER) THE DISTINCT POINTS OF THE C SEQUENCE T(K),...,T(N+1). C C KXL MATRIX WHERE C(I,J) = (I-1)ST RIGHT DERIVATIVE C OF THE PP AT BREAK(J) DIVIDED BY FACTORIAL(I-1). C L NUMBER OF POLYNOMIALS WHICH FORM THE PP C C WORK AREA ... C C WK 2-DIMENSIONAL ARRAY OF DIMENSION (K,K+1) C C----------------------------------------------------------------------- REAL T(*), A(N), BREAK(*), C(K,*), WK(K,*) C L = 0 BREAK(1) = T(K) IF (K .EQ. 1) GO TO 100 KM1 = K - 1 KP1 = K + 1 C C GENERAL K-TH ORDER CASE C DO 60 LEFT = K,N IF (T(LEFT) .EQ. T(LEFT + 1)) GO TO 60 L = L + 1 BREAK(L + 1) = T(LEFT + 1) DO 10 J = 1,K JJ = LEFT - K + J WK(J,1) = A(JJ) 10 CONTINUE C DO 21 J = 1,KM1 JP1 = J + 1 KMJ = K - J DO 20 I = 1,KMJ IL = I + LEFT ILKJ = IL - KMJ DIFF = T(IL) - T(ILKJ) WK(I,JP1) = (WK(I+1,J) - WK(I,J))/DIFF 20 CONTINUE 21 CONTINUE C WK(1,KP1) = 1.0 X = T(LEFT) C(K,L) = WK(1,K) R = 1.0 DO 50 J = 1,KM1 JP1 = J + 1 S = 0.0 DO 30 I = 1,J IL = I + LEFT ILJ = IL - J TERM = WK(I,KP1)/(T(IL) - T(ILJ)) WK(I,KP1) = S + (T(IL) - X)*TERM S = (X - T(ILJ))*TERM 30 CONTINUE WK(JP1,KP1) = S C S = 0.0 KMJ = K - J DO 40 I = 1,JP1 S = S + WK(I,KMJ)*WK(I,KP1) 40 CONTINUE R = (R*FLOAT(KMJ))/FLOAT(J) C(KMJ,L) = R*S 50 CONTINUE 60 CONTINUE RETURN C C PIECEWISE CONSTANT CASE C 100 DO 110 LEFT = K,N IF (T(LEFT) .EQ. T(LEFT + 1)) GO TO 110 L = L + 1 BREAK(L + 1) = T(LEFT + 1) C(1,L) = A(LEFT) 110 CONTINUE RETURN END SUBROUTINE PPVAL (X, A, L, N, XI, YI, NI) C----------------------------------------------------------------------- C C THIS ROUTINE EVALUATES A PIECEWISE POLYNOMIAL AT THE C ABSCISSAS IN XI. IT IS ASSUMED THAT THE COEFFICIENTS C OF THE POLYNOMIALS WHICH FORM THE PP ARE GIVEN. C C --INPUT-- C C X - ARRAY OF THE FIRST N ABSCISSAS (IN INCREASING ORDER) C THAT DEFINE THE PP. C A - MATRIX THAT CONTAINS THE COEFFICIENTS OF THE POLY- C NOMIALS WHICH FORM THE PP. IF I = 1,...,N THEN THE C PP HAS THE VALUE C A(1,I) + A(2,I)*DX + ... + A(L,I)*DX**(L-1) C FOR X(I) .LE. XX .LT. X(I+1). HERE DX = XX - X(I). C L - ORDER OF THE PIECEWISE POLYNOMIAL. C N - THE NUMBER OF POLYNOMIALS THAT DEFINE THE PP. C N MUST BE GREATER THAN OR EQUAL TO 1. C XI - THE ARRAY OF ABSCISSAS (IN ARBITRARY ORDER) AT WHICH C AT WHICH THE PP IS TO BE EVALUATED. C NI - THE DIMENSION OF THE ARRAYS XI AND YI. IT IS ASSUMED C THAT NI IS GREATER THAN OR EQUAL TO 1. C C --OUTPUT-- C C YI - ARRAY OF VALUES OF THE PP AT THE POINTS IN XI. C C----------------------------------------------------------------------- DIMENSION X(N), A(L,N), XI(NI), YI(NI) C C K IS INDEX ON VALUE OF XI BEING WORKED ON. XX IS THAT VALUE. C I IS THE CURRENT INDEX IN THE X ARRAY. C K = 1 XX = XI(1) LM1 = L - 1 IF (XX .LT. X(1)) GO TO 90 IF (XX .GE. X(N)) GO TO 80 IL = 1 IR = N C C BISECTION SEARCH C 10 I = (IL + IR)/2 IF (I .EQ. IL) GO TO 100 IF (XX - X(I)) 20,100,30 20 IR = I GO TO 10 30 IL = I GO TO 10 C C LINEAR FORWARD SEARCH C 40 IF (XX .LT. X(I+1)) GO TO 100 I = I + 1 GO TO 40 C C XX IS GREATER THAN X(N) OR LESS THAN X(1) C 80 I = N GO TO 100 90 I = 1 C C EVALUATION C 100 DX = XX - X(I) S = A(L,I) IF (L .EQ. 1) GO TO 120 DO 110 J = 1,LM1 LMJ = L - J S = A(LMJ,I) + DX*S 110 CONTINUE 120 YI(K) = S C C NEXT POINT C IF (K .GE. NI) RETURN K = K + 1 XX = XI(K) IF (XX .LT. X(1)) GO TO 90 IF (XX .GE. X(N)) GO TO 80 IF (XX - XI(K-1)) 130,120,40 130 IL = 1 IR = MIN0(I + 1, N) GO TO 10 END SUBROUTINE BSPVB (T, K, JHIGH, J, X, LEFT, BLIST) C----------------------------------------------------------------------- C C BSPVB CALCULATES THE VALUE OF ALL POSSIBLY NONZERO B-SPLINES C AT X OF ORDER MAX(JHIGH,J + 1) WHERE T(K) .LE. X .LT. T(N+1). C C DESCRIPTION OF ARGUMENTS C C INPUT C C T - KNOT VECTOR OF LENGTH N + K. C K - HIGHEST POSSIBLE ORDER OF THE B-SPLINES. C JHIGH - ORDER OF B-SPLINES (1 .LE. JHIGH .LE. K). C J - J .LE. 0 GIVES B-SPLINES OF ORDER JHIGH. C J .GE. 1 ON A PREVIOUS CALL TO BSPVB THE C B-SPLINES OF ORDER J WERE COM- C PUTED AND STORED IN BLIST. IT IS C ASSUMED THAT WORK HAS NOT BEEN C MODIFIED AND THAT J .LT. K. C X - ARGUMENT OF THE B-SPLINES. C LEFT - LARGEST INTEGER SUCH THAT C T(LEFT) .LE. X .LT. T(LEFT+1) C C OUTPUT C C BLIST - VECTOR OF LENGTH K FOR SPLINE VALUES. C J - B-SPLINES OF ORDER J HAVE BEEN COMPUTED C AND STORED IN BLIST. C C----------------------------------------------------------------------- C WRITTEN BY CARL DE BOOR (UNIVERSITY OF WISCONSIN) AND MODIFIED C BY A.H. MORRIS (NSWC). C----------------------------------------------------------------------- REAL T(*), BLIST(K) C IF (J .GT. 0) GO TO 10 J = 1 BLIST(1) = 1.0 IF (J .GE. JHIGH) RETURN C 10 S = 0.0 DO 20 L = 1,J I = LEFT + L IMJ = I - J TIMJ = T(IMJ) TI = T(I) TERM = BLIST(L)/(TI - TIMJ) BLIST(L) = S + (TI - X)*TERM S = (X - TIMJ)*TERM 20 CONTINUE J = J + 1 BLIST(J) = S IF (J .LT. JHIGH) GO TO 10 C RETURN END SUBROUTINE BSPVD (T, K, X, LEFT, DBIATX, IDIM, NDERIV, A) C----------------------------------------------------------------------- C C CALCULATES VALUE AND DERIV.S OF ALL B-SPLINES WHICH DO NOT VANISH AT X C C****** I N P U T ****** C C T THE KNOT ARRAY, OF LENGTH LEFT+K (AT LEAST) C K THE ORDER OF THE B-SPLINES TO BE EVALUATED C X THE POINT AT WHICH THESE VALUES ARE SOUGHT C LEFT AN INTEGER INDICATING THE LEFT ENDPOINT OF THE INTERVAL OF C INTEREST. THE K B-SPLINES WHOSE SUPPORT CONTAINS THE INTERVAL C (T(LEFT), T(LEFT+1)) C ARE TO BE CONSIDERED. C A S S U M P T I O N - - - IT IS ASSUMED THAT C T(LEFT) .LT. T(LEFT+1) C DIVISION BY ZERO WILL RESULT OTHERWISE (IN B S P V B ). C ALSO, THE OUTPUT IS AS ADVERTISED ONLY IF C T(LEFT) .LE. X .LE. T(LEFT+1) . C IDIM THE ROW DIMENSION OF THE MATRIX DBIATX. IF IS ASSUMED THAT C IDIM .GE. K . C NDERIV AN INTEGER INDICATING THAT VALUES OF B-SPLINES AND THEIR C DERIVATIVES UP TO BUT NOT INCLUDING THE NDERIV-TH ARE ASKED C FOR. (NDERIV IS REPLACED INTERNALLY BY THE INTEGER M H I G H C IN (1,K) CLOSEST TO IT.) C C****** O U T P U T ****** C C DBIATX AN ARRAY OF ORDER (IDIM,NDERIV). ITS ENTRY (I,M) CONTAINS C VALUE OF (M-1)ST DERIVATIVE OF (LEFT-K+I)-TH B-SPLINE OF C ORDER K FOR KNOT SEQUENCE T , I=M,...,K, M=1,...,NDERIV. C C****** W O R K A R E A ****** C C A AN ARRAY OF ORDER (K,K), TO CONTAIN B-COEFF.S OF THE DERIVA- C TIVES OF A CERTAIN ORDER OF THE K B-SPLINES OF INTEREST. C C****** M E T H O D ****** C C VALUES AT X OF ALL THE RELEVANT B-SPLINES OF ORDER K,K-1,..., C K+1-NDERIV ARE GENERATED VIA BSPVB AND STORED TEMPORARILY IN C DBIATX. THEN THE B-COEFFS OF THE REQUIRED DERIVATIVES OF THE B- C SPLINES OF INTEREST ARE GENERATED BY DIFFERENCING, EACH FROM THE PRE- C CEDING ONE OF LOWER ORDER, AND COMBINED WITH THE VALUES OF B-SPLINES C OF CORRESPONDING ORDER IN DBIATX TO PRODUCE THE DESIRED VALUES . C C----------------------------------------------------------------------- C WRITTEN BY CARL DE BOOR (UNIVERSITY OF WISCONSIN) AND MODIFIED C BY A.H. MORRIS (NSWC). C----------------------------------------------------------------------- REAL T(*), DBIATX(IDIM,NDERIV), A(K,K) C MHIGH = MAX0(MIN0(NDERIV,K),1) C MHIGH IS USUALLY EQUAL TO NDERIV. KP1 = K + 1 JJ = 0 CALL BSPVB (T, K, KP1 - MHIGH, JJ, X, LEFT, DBIATX) IF (MHIGH .EQ. 1) RETURN C C THE FIRST COLUMN OF DBIATX ALWAYS CONTAINS THE B-SPLINE VALUES C FOR THE CURRENT ORDER. THESE ARE STORED IN COLUMN K+1-CURRENT C ORDER BEFORE BSPVB IS CALLED TO PUT VALUES FOR THE NEXT C HIGHER ORDER ON TOP OF IT. C IDERIV = MHIGH DO 15 M = 2,MHIGH JP1MID = 1 DO 10 J = IDERIV,K DBIATX(J,IDERIV) = DBIATX(JP1MID,1) 10 JP1MID = JP1MID + 1 IDERIV = IDERIV - 1 CALL BSPVB (T, K, KP1 - IDERIV, JJ, X, LEFT, DBIATX) 15 CONTINUE C C AT THIS POINT, B(LEFT-K+I, K+1-J)(X) IS IN DBIATX(I,J) FOR C I = J,...,K AND J = 1,...,MHIGH. IN PARTICULAR, THE FIRST C COLUMN OF DBIATX IS ALREADY IN FINAL FORM. TO OBTAIN COR- C RESPONDING DERIVATIVES OF B-SPLINES IN SUBSEQUENT COLUMNS, C GENERATE THEIR B-REPR. BY DIFFERENCING. THEN EVALUATE AT X. C JLOW = 1 DO 20 I = 1,K DO 19 J = JLOW,K 19 A(J,I) = 0.0 JLOW = I 20 A(I,I) = 1.0 C C AT THIS POINT, A(.,J) CONTAINS THE B-COEFFS FOR THE J-TH OF THE C K B-SPLINES OF INTEREST HERE. C DO 50 M = 2,MHIGH KP1MM = KP1 - M FKP1MM = FLOAT(KP1MM) IL = LEFT I = K C C FOR J = 1,...,K, CONSTRUCT B-COEFFS OF (M-1)ST DERIVATIVE OF C B-SPLINES FROM THOSE FOR PRECEDING DERIVATIVE BY DIFFERENCING C AND STORE AGAIN IN A(.,J) . THE FACT THAT A(I,J) = 0 FOR C I .LT. J IS USED. C DO 30 LDUMMY = 1,KP1MM L = IL + KP1MM FACTOR = FKP1MM/(T(L) - T(IL)) C C THE ASSUMPTION THAT T(LEFT).LT.T(LEFT+1) MAKES DENOMINATOR C IN THE FACTOR NONZERO. C DO 25 J = 1,I 25 A(I,J) = (A(I,J) - A(I-1,J))*FACTOR IL = IL - 1 I = I - 1 30 CONTINUE C C FOR I = 1,...,K, COMBINE B-COEFFS A(.,I) WITH B-SPLINE VALUES C STORED IN DBIATX(.,M) TO GET VALUE OF (M-1)ST DERIVATIVE OF C I-TH B-SPLINE (OF INTEREST HERE) AT X, AND STORE IN C DBIATX(I,M). STORAGE OF THIS VALUE OVER THE VALUE OF A B-SPLINE C OF ORDER M THERE IS SAFE SINCE THE REMAINING B-SPLINE DERIVAT- C IVES OF THE SAME ORDER DO NOT USE THIS VALUE DUE TO THE FACT C THAT A(J,I) = 0 FOR J .LT. I . C DO 40 I = 1,K SUM = 0.0 JLOW = MAX0(I,M) DO 35 J=JLOW,K 35 SUM = A(J,I)*DBIATX(J,M) + SUM DBIATX(I,M) = SUM 40 CONTINUE 50 CONTINUE RETURN END SUBROUTINE BSTRP (TAU, GTAU, T, N, K, BCOEF, Q, IFLAG) C----------------------------------------------------------------------- C THIS ROUTINE PRODUCES THE B-SPLINE COEFF.S BCOEF OF THE PIECEWISE C POLYNOMIAL OF ORDER K WITH KNOTS T(I) (I=1,...,N+K) WHICH HAS THE C VALUE GTAU(I) AT TAU(I) FOR I=1,...,N. C C****** I N P U T ****** C C TAU.....ARRAY OF LENGTH N , CONTAINING DATA POINT ABSCISSAE. C A S S U M P T I O N . . . TAU IS STRICTLY INCREASING C GTAU.....CORRESPONDING ARRAY OF LENGTH N , CONTAINING DATA POINT C ORDINATES. C T.....KNOT SEQUENCE, OF LENGTH N+K C N.....NUMBER OF DATA POINTS AND DIMENSION OF SPLINE SPACE S(K,T) C K.....ORDER OF THE PIECEWISE POLYNOMIAL C IFLAG.....ON AN INITIAL CALL TO THE ROUTINE, IFLAG MAY BE ASSIGNED C ANY VALUE EXCEPT 0. THE ROUTINE MAY BE RECALLED WHEN ONLY GTAU C IS MODIFIED. IFLAG=0 WHEN THIS IS DONE. C C****** O U T P U T ****** C C BCOEF.....THE B-COEFFICIENTS OF THE INTERPOLANT, OF LENGTH N C Q.....ARRAY OF SIZE (2*K-1)*N , CONTAINING THE TRIANGULAR FACTORIZ- C ATION OF THE COEFFICIENT MATRIX OF THE LINEAR SYSTEM FOR THE B- C COEFFICIENTS OF THE SPLINE INTERPOLANT. C IFLAG.....AN INTEGER INDICATING SUCCESS (= 0) OR FAILURE (= 1) C THE LINEAR SYSTEM TO BE SOLVED IS (THEORETICALLY) INVERTIBLE IF C AND ONLY IF C B(I)(TAU(I)) .NE. 0 FOR ALL I. C VIOLATION OF THIS CONDITION IS CERTAIN TO LEAD TO IFLAG = 1. C C****** M E T H O D ****** C C THE I-TH EQUATION OF THE LINEAR SYSTEM A*BCOEF = B FOR THE B-CO- C EFFS OF THE INTERPOLANT ENFORCES INTERPOLATION AT TAU(I), I=1,...,N. C HENCE, B(I) = GTAU(I), ALL I, AND A IS A BAND MATRIX WITH 2K-1 C BANDS (IF IT IS INVERTIBLE). C THE MATRIX A IS GENERATED ROW BY ROW AND STORED, DIAGONAL BY DI- C AGONAL, IN THE R O W S OF THE ARRAY Q , WITH THE MAIN DIAGONAL GO- C ING INTO ROW K . SEE COMMENTS IN THE PROGRAM BELOW. C THE BANDED SYSTEM IS THEN SOLVED BY A CALL TO BANFAC (WHICH CON- C STRUCTS THE TRIANGULAR FACTORIZATION FOR A AND STORES IT IN Q), C FOLLOWED BY A CALL TO BANSLV (WHICH THEN OBTAINS THE SOLUTION BCOEF C BY SUBSTITUTION). C BANFAC PERFORMS NO PIVOTING SINCE THE TOTAL POSITIVITY OF THE C MATRIX A MAKES THIS UNNECESSARY. C----------------------------------------------------------------------- REAL BCOEF(N), GTAU(N), Q(*), T(*), TAU(N) C KM1 = K - 1 IF (IFLAG .EQ. 0) GO TO 60 NP1 = N + 1 KPKM2 = 2*KM1 IF (N .EQ. 1) GO TO 20 C C CHECK IF TAU(I) IS AN INCREASING SEQUENCE C DO 10 I = 2,N IF (TAU(I) .LE. TAU(I-1)) GO TO 100 10 CONTINUE C C ZERO OUT ALL ENTRIES OF Q C 20 IF (TAU(N) .GT. T(NP1)) GO TO 100 LENQ = N*(K + KM1) DO 21 I = 1,LENQ Q(I) = 0.0 21 CONTINUE C C *** LOOP OVER I TO CONSTRUCT THE N INTERPOLATION EQUATIONS C LEFT = K DO 51 I = 1,N TAUI = TAU(I) ILP1MX = MIN0(I + K,NP1) C C *** FIND LEFT IN THE CLOSED INTERVAL (I,I+K-1) SUCH THAT C T(LEFT) .LE. TAU(I) .LT. T(LEFT+1) C MATRIX IS SINGULAR IF THIS IS NOT POSSIBLE C LEFT = MAX0(LEFT,I) IF (TAUI .LT. T(LEFT)) GO TO 100 30 IF (TAUI .LT. T(LEFT+1)) GO TO 40 LEFT = LEFT + 1 IF (LEFT .LT. ILP1MX) GO TO 30 IF (LEFT .EQ. I + K) GO TO 100 LEFT = N C C *** THE I-TH EQUATION ENFORCES INTERPOLATION AT TAUI, HENCE C A(I,J) = B(J,K,T)(TAUI), ALL J. ONLY THE K ENTRIES WITH J = C LEFT-K+1,...,LEFT ACTUALLY MIGHT BE NONZERO. THESE K NUMBERS C ARE RETURNED, IN BCOEF (USED FOR TEMP.STORAGE HERE), BY THE C FOLLOWING C 40 JJ = 0 CALL BSPVB (T, K, K, JJ, TAUI, LEFT, BCOEF) C C LET Q DENOTE A TWO-DIMENSIONAL ARRAY OF DIMENSION (2*K-1,N). C WE THEREFORE WANT BCOEF(J) = B(LEFT-K+J)(TAUI) TO GO INTO C A(I,LEFT-K+J), I.E., INTO Q(I-(LEFT+J)+2*K,(LEFT+J)-K) SINCE C A(I+J,J) IS TO GO INTO Q(I+K,J), ALL I,J. IN THE CURRENT C ROUTINE WE TREAT Q AS AN EQUIVALENT ONE-DIMENSIONAL ARRAY. C THUS WE WANT BCOEF(J) TO BE INSERTED INTO ENTRY C I - (LEFT+J) + 2*K + ((LEFT+J) - K-1)*(2*K-1) C = I-LEFT+1 + (LEFT - K)*(2*K-1) + (2*K-2)*J C OF Q . C JJ = I - LEFT + 1 + (LEFT - K)*(K + KM1) DO 50 J = 1,K JJ = JJ + KPKM2 Q(JJ) = BCOEF(J) 50 CONTINUE 51 CONTINUE C C ***OBTAIN FACTORIZATION OF A , STORED AGAIN IN Q. C CALL BANFAC (Q, K + KM1, N, KM1, KM1, IFLAG) IFLAG = IFLAG - 1 IF (IFLAG .NE. 0) RETURN C C *** SOLVE A*BCOEF = GTAU BY BACKSUBSTITUTION C 60 DO 61 I = 1,N BCOEF(I) = GTAU(I) 61 CONTINUE CALL BANSLV (Q, K + KM1, N, KM1, KM1, BCOEF) RETURN C C *** ERROR RETURN C 100 IFLAG = 1 RETURN END SUBROUTINE BANFAC ( W, NROWW, NROW, NBANDL, NBANDU, IFLAG ) C FROM * A PRACTICAL GUIDE TO SPLINES * BY C. DE BOOR C RETURNS IN W THE LU-FACTORIZATION (WITHOUT PIVOTING) OF THE BANDED C MATRIX A OF ORDER NROW WITH (NBANDL + 1 + NBANDU) BANDS OR DIAG- C ONALS IN THE WORK ARRAY W . C C****** I N P U T ****** C W.....WORK ARRAY OF SIZE (NROWW,NROW) CONTAINING THE INTERESTING C PART OF A BANDED MATRIX A , WITH THE DIAGONALS OR BANDS OF A C STORED IN THE ROWS OF W , WHILE COLUMNS OF A CORRESPOND TO C COLUMNS OF W . THIS IS THE STORAGE MODE USED IN LINPACK AND C RESULTS IN EFFICIENT INNERMOST LOOPS. C EXPLICITLY, A HAS NBANDL BANDS BELOW THE DIAGONAL C + 1 (MAIN) DIAGONAL C + NBANDU BANDS ABOVE THE DIAGONAL C AND THUS, WITH MIDDLE = NBANDU + 1, C A(I+J,J) IS IN W(I+MIDDLE,J) FOR I=-NBANDU,...,NBANDL C J=1,...,NROW . C FOR EXAMPLE, THE INTERESTING ENTRIES OF A (1,2)-BANDED MATRIX C OF ORDER 9 WOULD APPEAR IN THE FIRST 1+1+2 = 4 ROWS OF W C AS FOLLOWS. C 13 24 35 46 57 68 79 C 12 23 34 45 56 67 78 89 C 11 22 33 44 55 66 77 88 99 C 21 32 43 54 65 76 87 98 C C ALL OTHER ENTRIES OF W NOT IDENTIFIED IN THIS WAY WITH AN EN- C TRY OF A ARE NEVER REFERENCED . C NROWW.....ROW DIMENSION OF THE WORK ARRAY W . C MUST BE .GE. NBANDL + 1 + NBANDU . C NBANDL.....NUMBER OF BANDS OF A BELOW THE MAIN DIAGONAL C NBANDU.....NUMBER OF BANDS OF A ABOVE THE MAIN DIAGONAL . C C****** O U T P U T ****** C IFLAG.....INTEGER INDICATING SUCCESS( = 1) OR FAILURE ( = 2) . C IF IFLAG = 1, THEN C W.....CONTAINS THE LU-FACTORIZATION OF A INTO A UNIT LOWER TRIANGU- C LAR MATRIX L AND AN UPPER TRIANGULAR MATRIX U (BOTH BANDED) C AND STORED IN CUSTOMARY FASHION OVER THE CORRESPONDING ENTRIES C OF A . THIS MAKES IT POSSIBLE TO SOLVE ANY PARTICULAR LINEAR C SYSTEM A*X = B FOR X BY A C CALL BANSLV ( W, NROWW, NROW, NBANDL, NBANDU, B ) C WITH THE SOLUTION X CONTAINED IN B ON RETURN . C IF IFLAG = 2, THEN C ONE OF NROW-1, NBANDL,NBANDU FAILED TO BE NONNEGATIVE, OR ELSE C ONE OF THE POTENTIAL PIVOTS WAS FOUND TO BE ZERO INDICATING C THAT A DOES NOT HAVE AN LU-FACTORIZATION. THIS IMPLIES THAT C A IS SINGULAR IN CASE IT IS TOTALLY POSITIVE . C C****** M E T H O D ****** C GAUSS ELIMINATION W I T H O U T PIVOTING IS USED. THE ROUTINE IS C INTENDED FOR USE WITH MATRICES A WHICH DO NOT REQUIRE ROW INTER- C CHANGES DURING FACTORIZATION, ESPECIALLY FOR THE T O T A L L Y C P O S I T I V E MATRICES WHICH OCCUR IN SPLINE CALCULATIONS. C THE ROUTINE SHOULD NOT BE USED FOR AN ARBITRARY BANDED MATRIX. C REAL W(NROWW,NROW), FACTOR,PIVOT C IFLAG = 1 MIDDLE = NBANDU + 1 C W(MIDDLE,.) CONTAINS THE MAIN DIAGONAL OF A . NROWM1 = NROW - 1 IF (NROWM1) 999,900,1 1 IF (NBANDL .GT. 0) GO TO 10 C A IS UPPER TRIANGULAR. CHECK THAT DIAGONAL IS NONZERO . DO 5 I=1,NROWM1 IF (W(MIDDLE,I) .EQ. 0.) GO TO 999 5 CONTINUE GO TO 900 10 IF (NBANDU .GT. 0) GO TO 20 C A IS LOWER TRIANGULAR. CHECK THAT DIAGONAL IS NONZERO AND C DIVIDE EACH COLUMN BY ITS DIAGONAL . DO 15 I=1,NROWM1 PIVOT = W(MIDDLE,I) IF(PIVOT .EQ. 0.) GO TO 999 JMAX = MIN0(NBANDL, NROW - I) JBEG = MIDDLE + 1 JEND = MIDDLE + JMAX DO 15 J=JBEG,JEND 15 W(J,I) = W(J,I)/PIVOT GO TO 900 C C A IS NOT JUST A TRIANGULAR MATRIX. CONSTRUCT LU FACTORIZATION 20 DO 50 I=1,NROWM1 C W(MIDDLE,I) IS PIVOT FOR I-TH STEP . PIVOT = W(MIDDLE,I) IF (PIVOT .EQ. 0.) GO TO 999 C JMAX IS THE NUMBER OF (NONZERO) ENTRIES IN COLUMN I C BELOW THE DIAGONAL . JMAX = MIN0(NBANDL,NROW - I) C DIVIDE EACH ENTRY IN COLUMN I BELOW DIAGONAL BY PIVOT . JBEG = MIDDLE + 1 JEND = MIDDLE + JMAX DO 32 J=JBEG,JEND 32 W(J,I) = W(J,I)/PIVOT C KMAX IS THE NUMBER OF (NONZERO) ENTRIES IN ROW I TO C THE RIGHT OF THE DIAGONAL . KMAX = MIN0(NBANDU,NROW - I) C SUBTRACT A(I,I+K)*(I-TH COLUMN) FROM (I+K)-TH COLUMN C (BELOW ROW I ) . DO 40 K=1,KMAX IPK = I + K MIDMK = MIDDLE - K FACTOR = W(MIDMK,IPK) DO 40 J=1,JMAX MJ = MIDDLE + J MDJ = MIDMK + J 40 W(MDJ,IPK) = W(MDJ,IPK) - W(MJ,I)*FACTOR 50 CONTINUE C CHECK THE LAST DIAGONAL ENTRY . 900 IF (W(MIDDLE,NROW) .NE. 0.) RETURN 999 IFLAG = 2 RETURN END SUBROUTINE BANSLV ( W, NROWW, NROW, NBANDL, NBANDU, B ) C FROM * A PRACTICAL GUIDE TO SPLINES * BY C. DE BOOR C COMPANION ROUTINE TO BANFAC . IT RETURNS THE SOLUTION X OF THE C LINEAR SYSTEM A*X = B IN PLACE OF B , GIVEN THE LU-FACTORIZATION C FOR A IN THE WORKARRAY W . C C****** I N P U T ****** C W, NROWW,NROW,NBANDL,NBANDU.....DESCRIBE THE LU-FACTORIZATION OF A C BANDED MATRIX A OF RODER NROW AS CONSTRUCTED IN BANFAC . C FOR DETAILS, SEE BANFAC . C B.....RIGHT SIDE OF THE SYSTEM TO BE SOLVED . C C****** O U T P U T ****** C B.....CONTAINS THE SOLUTION X , OF ORDER NROW . C C****** M E T H O D ****** C (WITH A = L*U, AS STORED IN W,) THE UNIT LOWER TRIANGULAR SYSTEM C L(U*X) = B IS SOLVED FOR Y = U*X, AND Y STORED IN B . THEN THE C UPPER TRIANGULAR SYSTEM U*X = Y IS SOLVED FOR X . THE CALCUL- C ATIONS ARE SO ARRANGED THAT THE INNERMOST LOOPS STAY WITHIN COLUMNS. C REAL W(NROWW,NROW),B(NROW) MIDDLE = NBANDU + 1 IF (NROW .EQ. 1) GO TO 49 NROWM1 = NROW - 1 IF (NBANDL .EQ. 0) GO TO 30 C FORWARD PASS C FOR I=1,2,...,NROW-1, SUBTRACT RIGHT SIDE(I)*(I-TH COLUMN C OF L ) FROM RIGHT SIDE (BELOW I-TH ROW) . DO 21 I=1,NROWM1 JMAX = MIN0(NBANDL, NROW-I) DO 21 J=1,JMAX IPJ = I + J MPJ = MIDDLE + J 21 B(IPJ) = B(IPJ) - B(I)*W(MPJ,I) C BACKWARD PASS C FOR I=NROW,NROW-1,...,1, DIVIDE RIGHT SIDE(I) BY I-TH DIAG- C ONAL ENTRY OF U, THEN SUBTRACT RIGHT SIDE(I)*(I-TH COLUMN C OF U) FROM RIGHT SIDE (ABOVE I-TH ROW). 30 IF (NBANDU .GT. 0) GO TO 40 C A IS LOWER TRIANGULAR . DO 31 I=1,NROW 31 B(I) = B(I)/W(1,I) RETURN 40 I = NROW 41 B(I) = B(I)/W(MIDDLE,I) JMAX = MIN0(NBANDU,I-1) DO 45 J=1,JMAX IMJ = I - J MMJ = MIDDLE - J 45 B(IMJ) = B(IMJ) - B(I)*W(MMJ,I) I = I - 1 IF (I .GT. 1) GO TO 41 49 B(1) = B(1)/W(MIDDLE,1) RETURN END SUBROUTINE BSLSQ (TAU, GTAU, WGT, NTAU, T, N, K, A, WK, Q, IERR) C----------------------------------------------------------------------- C C BSLSQ PRODUCES THE B-SPLINE COEFFICIENTS OF A PIECEWISE C POLYNOMIAL P(X) OF ORDER K WHICH MINIMIZES C C SUM (WGT(J)*(P(TAU(J)) - GTAU(J))**2). C C C INPUT ... C C TAU ARRAY OF LENGTH NTAU CONTAINING DATA POINT ABSCISSAE. C GTAU ARRAY OF LENGTH NTAU CONTAINING DATA POINT ORDINATES. C WGT ARRAY OF LENGTH NTAU CONTAINING THE WEIGHTS. C NTAU NUMBER OF DATA POINTS TO BE FITTED. C T KNOT SEQUENCE OF LENGTH N + K. C N DIMENSION OF THE PIECEWISE POLYNOMIAL SPACE. C K ORDER OF THE B-SPLINES. C C OUTPUT ... C C A ARRAY OF LENGTH N CONTAINING THE B-SPLINE COEFFICIENTS C OF THE L2 APPROXIMATION. C C IERR INTEGER REPORTING THE STATUS OF THE RESULTS ... C C 0 THE COEFFICIENT MATRIX IS NONSIGULAR. THE C UNIQUE LEAST SQUARES SOLUTION WAS OBTAINED. C 1 THE COEFFICIENT MATRIX IS SINGULAR. A C LEAST SQUARES SOLUTION WAS OBTAINED. C -1 INPUT ERRORS WERE DETECTED. C C----------------------------------------------------------------------- REAL TAU(NTAU), GTAU(NTAU), WGT(NTAU) REAL T(*), A(N), WK(N), Q(K,N) C IF (NTAU .LT. MAX0(2,K)) GO TO 100 IF (TAU(1) .LT. T(K) .OR. TAU(NTAU) .GT. T(N + 1)) GO TO 100 C DO 10 I = 2,NTAU IF (TAU(I - 1) .GT. TAU(I)) GO TO 100 10 CONTINUE C DO 21 J = 1,N A(J) = 0.0 DO 20 I = 1,K Q(I,J) = 0.0 20 CONTINUE 21 CONTINUE C LEFT = K DO 70 L = 1,NTAU C C *** FIND THE INDEX LEFT SUCH THAT C T(LEFT) .LE. TAU(L) .LT. T(LEFT+1) C 30 IF (LEFT .EQ. N) GO TO 40 IF (TAU(L) .LT. T(LEFT+1)) GO TO 40 LEFT = LEFT + 1 GO TO 30 C 40 JJ = 0 CALL BSPVB (T, K, K, JJ, TAU(L), LEFT, WK) C LEFTMK = LEFT - K DO 61 MM = 1,K DW = WK(MM)*WGT(L) J = LEFTMK + MM A(J) = DW*GTAU(L) + A(J) I = 1 DO 60 JJ = MM,K Q(I,J) = WK(JJ)*DW + Q(I,J) I = I + 1 60 CONTINUE 61 CONTINUE 70 CONTINUE C C SOLVE THE NORMAL EQUATIONS C CALL BCHFAC (Q, K, N, WK, IERR) CALL BCHSLV (Q, K, N, A) RETURN C C ERROR RETURN C 100 IERR = -1 RETURN END SUBROUTINE BCHFAC (W, NB, N, DIAG, IFLAG) C----------------------------------------------------------------------- C FROM * A PRACTICAL GUIDE TO SPLINES * BY C. DE BOOR C CONSTRUCTS CHOLESKY FACTORIZATION C C = L * D * L-TRANSPOSE C WITH L UNIT LOWER TRIANGULAR AND D DIAGONAL, FOR GIVEN MATRIX C OF C ORDER N , IN CASE C IS (SYMMETRIC) POSITIVE SEMIDEFINITE C AND BANDED, HAVING NB DIAGONALS AT AND BELOW THE MAIN DIAGONAL. C C****** INPUT ****** C C N THE ORDER OF THE MATRIX C. C C NB THE BANDWIDTH OF C, I.E., C C(I,J) = 0 FOR ABS(I-J) .GT. NB . C C W WORK ARRAY OF SIZE NB BY N CONTAINING THE NB DIAGONALS C IN ITS ROWS, WITH THE MAIN DIAGONAL IN ROW 1. PRECISELY, C W(I,J) CONTAINS C(I+J-1,J), I=1,...,NB, J=1,...,N. C FOR EXAMPLE, THE INTERESTING ENTRIES OF A SEVEN DIAGONAL C SYMMETRIC MATRIX C OF ORDER 9 WOULD BE STORED IN W AS C C 11 22 33 44 55 66 77 88 99 C 21 32 43 54 65 76 87 98 C 31 42 53 64 75 86 97 C 41 52 63 74 85 96 C C ALL OTHER ENTRIES OF W NOT IDENTIFIED WITH AN ENTRY OF C C ARE NEVER REFERENCED. C C DIAG WORK ARRAY OF LENGTH N. C C****** O U T P U T ****** C T C W CONTAINS THE CHOLESKY FACTORIZATION C = L*D*L WHERE C W(1,I) = 1/D(I,I) AND W(I,J) = L(I-1+J,J) (I=2,...,NB). C C IFLAG 0 IF C IS NONSINGULAR AND 1 IF C IS SINGULAR. C C****** M E T H O D ****** C C GAUSS ELIMINATION, ADAPTED TO THE SYMMETRY AND BANDEDNESS OF C , IS C USED . C NEAR ZERO PIVOTS ARE HANDLED IN A SPECIAL WAY. THE DIAGONAL ELE- C MENT C(K,K) = W(1,K) IS SAVED INITIALLY IN DIAG(K), ALL K. AT THE K- C TH ELIMINATION STEP, THE CURRENT PIVOT ELEMENT, VIZ. W(1,K), IS COM- C PARED WITH ITS ORIGINAL VALUE, DIAG(K). IF, AS THE RESULT OF PRIOR C ELIMINATION STEPS, THIS ELEMENT HAS BEEN REDUCED BY ABOUT A WORD C LENGTH, (I.E., IF W(1,K)+DIAG(K) .LE. DIAG(K)), THEN THE PIVOT IS DE- C CLARED TO BE ZERO, AND THE ENTIRE K-TH ROW IS DECLARED TO BE LINEARLY C DEPENDENT ON THE PRECEDING ROWS. THIS HAS THE EFFECT OF PRODUCING C X(K) = 0 WHEN SOLVING C*X = B FOR X, REGARDLESS OF B. JUSTIFIC- C ATION FOR THIS IS AS FOLLOWS. IN CONTEMPLATED APPLICATIONS OF THIS C PROGRAM, THE GIVEN EQUATIONS ARE THE NORMAL EQUATIONS FOR SOME LEAST- C SQUARES APPROXIMATION PROBLEM, DIAG(K) = C(K,K) GIVES THE NORM-SQUARE C OF THE K-TH BASIS FUNCTION, AND, AT THIS POINT, W(1,K) CONTAINS THE C NORM-SQUARE OF THE ERROR IN THE LEAST-SQUARES APPROXIMATION TO THE K- C TH BASIS FUNCTION BY LINEAR COMBINATIONS OF THE FIRST K-1 . HAVING C W(1,K)+DIAG(K) .LE. DIAG(K) SIGNIFIES THAT THE K-TH FUNCTION IS LIN- C EARLY DEPENDENT TO MACHINE ACCURACY ON THE FIRST K-1 FUNCTIONS, THERE C FORE CAN SAFELY BE LEFT OUT FROM THE BASIS OF APPROXIMATING FUNCTIONS C THE SOLUTION OF A LINEAR SYSTEM C C*X = B C IS EFFECTED BY THE SUCCESSION OF THE FOLLOWING T W O CALLS ... C CALL BCHFAC (W, NB, N, DIAG, IFLAG) , TO GET FACTORIZATION C CALL BCHSLV (W, NB, N, B, X ) , TO SOLVE FOR X. C----------------------------------------------------------------------- REAL W(NB,N), DIAG(N) C IF (N .GT. 1) GO TO 10 IFLAG = 1 IF (W(1,1) .EQ. 0.0) RETURN IFLAG = 0 W(1,1) = 1.0/W(1,1) RETURN C C STORE THE DIAGONAL OF C IN DIAG C 10 DO 11 K = 1,N DIAG(K) = W(1,K) 11 CONTINUE C C FACTORIZATION C IFLAG = 0 DO 60 K = 1,N T = W(1,K) + DIAG(K) IF (T .NE. DIAG(K)) GO TO 30 IFLAG = 1 DO 20 J = 1,NB W(J,K) = 0.0 20 CONTINUE GO TO 60 C 30 T = 1.0/W(1,K) W(1,K) = T IMAX = MIN0(NB - 1,N - K) IF (IMAX .LT. 1) GO TO 60 JMAX = IMAX DO 50 I = 1,IMAX RATIO = T*W(I+1,K) KPI = K + I DO 40 J = 1,JMAX IPJ = I + J W(J,KPI) = W(J,KPI) - W(IPJ,K)*RATIO 40 CONTINUE JMAX = JMAX - 1 W(I+1,K) = RATIO 50 CONTINUE 60 CONTINUE RETURN END SUBROUTINE BCHSLV (W, NB, N, B) C----------------------------------------------------------------------- C C BCHSLV SOLVES THE LINEAR SYSTEM C*X = B FOR X WHEN W CONTAINS C THE CHOLESKY FACTORIZATION OBTAINED BY THE SUBROUTINE BCHFAC C FOR THE BANDED SYMMETRIC POSITIVE DEFINITE MATRIX C. C C INPUT ... C C N THE ORDER OF THE MATRIX C C NB THE BANDWIDTH OF C C W THE CHOLESKY FACTORIZATION OF C C B VECTOR OF LENGTH N CONTAINING THE RIGHT SIDE C C OUTPUT ... C C B SOLUTION X OF THE LINEAR SYSTEM C*X = B C C T C NOTE. THE FACTORIZATION C = L*D*L IS USED, WHERE L IS A C UNIT LOWER TRIANGULAR MATRIX AND D A DIAGONAL MATRIX. C C----------------------------------------------------------------------- REAL W(NB,N), B(N) C IF (N .GT. 1) GO TO 10 B(1) = B(1)*W(1,1) RETURN C C FORWARD SUBSTITUTION. SOLVE L*Y = B FOR Y AND STORE Y IN B. C 10 NBM1 = NB - 1 DO 30 K = 1,N JMAX = MIN0(NBM1,N - K) IF (JMAX .LT. 1) GO TO 30 DO 20 J = 1,JMAX JPK = J + K B(JPK) = B(JPK) - W(J + 1,K)*B(K) 20 CONTINUE 30 CONTINUE C T -1 C BACKSUBSTITUTION. SOLVE L X = D Y FOR X AND STORE X IN B. C K = N 40 B(K) = B(K)*W(1,K) JMAX = MIN0(NBM1,N - K) IF (JMAX .LT. 1) GO TO 60 DO 50 J = 1,JMAX JPK = J + K B(K) = B(K) - W(J + 1,K)*B(JPK) 50 CONTINUE 60 K = K - 1 IF (K .GT. 0) GO TO 40 RETURN END SUBROUTINE BFIT (BKPT, N, NORD, XDATA, YDATA, NDATA, * XCONST, YCONST, NDERIV, NCONST, * MODE, COEFF, RNORM, W, IW) C----------------------------------------------------------------------- C C THIS SUBPROGRAM FITS A PIECE-WISE POLYNOMIAL CURVE C TO DISCRETE DATA. THE PIECE-WISE POLYNOMIALS ARE C REPRESENTED AS B-SPLINES. C THE FITTING IS DONE IN A LEAST SQUARES SENSE. C EQUALITY AND INEQUALITY CONSTRAINTS CAN BE IMPOSED C ON THE FITTED CURVE. C C INPUT.. C C N,NORD,BKPT(*) N IS THE NUMBER OF COEFFICIENTS TO BE COM- C PUTED AND NORD IS THE ORDER OF THE B-SPLINE. C IT IS ASSUMED THAT N .GE. NORD. THE N + NORD C KNOTS OF THE SPLINE ARE IN THE ARRAY BKPT(*). C IT IS ASSUMED THAT THE KNOTS FORM A NONDE- C CREASING SEQUENCE. THE PROBLEM DATA INTERVAL C LIES BETWEEN THE POINTS BKPT(NORD) AND C BKPT(N+1). THE ADDITIONAL END KNOTS BKPT(I), C I = 1,...,NORD-1 AND I = N+2,...,N+NORD, ARE C REQUIRED TO COMPUTE THE FUNCTIONS USED TO C FIT THE DATA. C C (THE ORDER OF THE B-SPLINE IS ONE MORE THAN C THE DEGREE OF THE PIECEWISE POLYNOMIAL. FOR C EXAMPLE, NORD=4 WHEN WE ARE USING PIECEWISE C CUBICS.) C C NDATA,XDATA(*), C YDATA(*) THE NDATA DISCRETE (X,Y) PAIRS ARE IN C THE ARRAYS XDATA(*) AND YDATA(*). IT IS C ASSUMED THAT XDATA(*) IS AN INCREASING C SEQUENCE, XDATA(1) .GE. BKPT(NORD), AND C XDATA(NDATA) .LE. BKPT(N+1). C C NCONST,XCONST(*), C YCONST(*),NDERIV(*) C THE NUMBER OF CONDITIONS THAT CONSTRAIN C THE B-SPLINE IS NCONST. A CONSTRAINT IS C SPECIFIED BY AN (X,Y) PAIR IN THE ARRAYS C XCONST(*) AND YCONST(*), AND BY THE TYPE C OF CONSTRAINT AND DERIVATIVE VALUE ENCODED C IN THE ARRAY NDERIV(*). IT IS ASSUMED THAT C THE VALUES IN XCONST(*) ARE IN THE CLOSED C INTERVAL (BKPT(NORD),BKPT(N+1)). THE CON- C STRAINTS MAY BE GIVEN IN ANY ORDER. THE C VALUE OF NDERIV(*) IS DETERMINED AS FOLLOWS. C SUPPOSE THE I-TH CONSTRAINT APPLIES TO THE C J-TH DERIVATIVE OF THE B-SPLINE. (ANY C NONNEGATIVE VALUE OF J .LT. NORD IS PERMITTED. C IN PARTICULAR, THE VALUE J = 0 REFERS TO THE C B-SPLINE ITSELF.) C FOR THIS I-TH CONSTRAINT, SET C XCONST(I) = X, C YCONST(I) = Y, AND C NDERIV(I) = ITYPE + 4*J WHERE C C ITYPE = 0, IF (J-TH DERIV. AT X) .LE. Y. C = 1, IF (J-TH DERIV. AT X) .GE. Y. C = 2, IF (J-TH DERIV. AT X) .EQ. Y. C = 3, IF (J-TH DERIV. AT X) .EQ. C (J-TH DERIV. AT Y). C (A NEGATIVE VALUE FOR NDERIV(I) WILL CAUSE C THIS CONSTRAINT TO BE IGNORED. THIS C FEATURE IS OFTEN USEFUL WHEN TEMPORARILY C SUPPRESSING A CONSTRAINT WHILE STILL C RETAINING THE SOURCE CODE OF THE CALLING C PROGRAM.) C C MODE AN INPUT FLAG THAT DIRECTS THE LEAST C SQUARES SOLUTION METHOD USED BY BFIT( ). C C MODE = 0 A NEW PROBLEM. C C MODE .NE. 0 AN OLD PROBLEM. C C BY AN OLD PROBLEM IT IS MEANT THAT BFIT( ) C WAS LAST CALLED WITH THE SAME SET OF KNOTS C AND DATA POINTS. (THE CONSTRAINTS MAY BE C DIFFERENT THAN BEFORE.) C C C IW(1),IW(2) THE AMOUNTS OF WORKING STORAGE ACTUALLY C ALLOCATED FOR THE WORKING ARRAYS W(*) AND C IW(*). THESE QUANTITIES ARE COMPARED WITH THE C ACTUAL AMOUNTS OF STORAGE NEEDED IN BFIT( ). C INSUFFICIENT STORAGE ALLOCATED FOR C EITHER W(*) OR IW(*) IS AN ERROR. C C LENGTH OF W(*) MUST BE AT LEAST C C NB = (N + 3)*(NORD + 1) + NORD**2 C C AND THE LENGTH OF IW(*) MUST BE AT LEAST 2. C WHENEVER POSSIBLE THE CODE USES BANDED MATRIX C PROCESSORS BNDACC( ) AND BNDSL( ). THESE C ARE UTILIZED IF THERE ARE NO CONSTRAINTS AND C THERE IS SUFFICIENT DATA TO UNIQUELY DETERMINE C THE B-SPLINE COEFFICENTS. C C IF THE BAND PROCESSORS CANNOT BE USED TO C DETERMINE THE SOLUTION, THEN THE CONSTRAINED C LEAST SQUARES CODE LSEI( ) IS USED. C IN THIS CASE THE SUBPROGRAM REQUIRES AN C ADDITIONAL BLOCK OF STORAGE IN W(*). FOR THE C DISCUSSION HERE DEFINE THE INTEGERS C NEQCON AND NINCON RESPECTIVELY AS THE C NUMBER OF EQUALITY (ITYPE=2,3) AND C INEQUALITY (ITYPE=0,1) CONSTRAINTS C IMPOSED ON THE FITTED CURVE. DEFINE C C L = N + 1 C C AND NOTE THAT C C NCONST = NEQCON + NINCON. C C WHEN THE SUBPROGRAM BFIT( ) USES LSEI( ) THE C LENGTH OF THE WORKING ARRAY W(*) MUST BE AT C LEAST C C LW = NB + (L+NCONST)*L + 2*(NEQCON+L) C + (NINCON + L) + (NINCON+2)*(L+6) C C AND THE LENGTH OF THE ARRAY IW(*) MUST BE AT C LEAST C C IW1 = NINCON + 2*L . C C OUTPUT.. C C MODE AN OUTPUT FLAG THAT INDICATES THE STATUS C OF THE CONSTRAINED CURVE FIT. C C =-1 EITHER NORD .LT. 1 OR NORD .GT. N. C C =-2 EITHER NDATA .LT. 1 OR NCONST .LT. 0. C C =-3 BKPT(I) .GT. BKPT(I+1) FOR SOME I. C C =-4 XDATA(*) IS NOT AN INCREASING C SEQUENCE IN THE CLOSED INTERVAL C (BKPT(NORD), BKPT(N+1)). C C =-5 THE I-TH CONSTRAINT IS INCORRECT C FOR THE VALUE OF I STORED IN IW(2). C C =-6 INSUFF. STORAGE FOR W(*). IW(1) HAS C BEEN RESET TO THE AMOUNT OF STORAGE C NEEDED BY W(*). C C =-7 INSUFF. STORAGE FOR IW(*). IW(2) HAS C BEEN RESET TO THE AMOUNT OF STORAGE C NEEDED BY IW(*). C C = 0 SUCCESSFUL CONSTRAINED CURVE FIT. C C = 1 THE REQUESTED EQUALITY CONSTRAINTS C ARE CONTRADICTORY. C C = 2 THE PROBLEM CANNOT BE SOLVED. THE C CONSTRAINTS ARE CONTRADICTORY. C C COEFF(*) C IF THE OUTPUT VALUE OF MODE=0 OR 1, COEFF(*) C CONTAINS THE N UNKNOWNS OBTAINED FROM THE C LEAST SQUARES FITTING PROCESS. THESE N C PARAMETERS ARE THE B-SPLINE COEFFICIENTS. C FOR MODE=1, THE EQUALITY CONSTRAINTS ARE C CONTRADICTORY. TO MAKE THE FITTING PROCESS C MORE ROBUST, THE EQUALITY CONSTRAINTS ARE C SATISFIED IN A LEAST SQUARES SENSE. IN C THIS CASE THE ARRAY COEFF(*) CONTAINS C B-SPLINE COEFFICIENTS FOR THIS EXTENDED C CONCEPT OF A SOLUTION. C IF MODE .LT. 0 OR MODE = 2 ON OUTPUT, THE C ARRAY COEFF(*) IS UNDEFINED. C C RNORM IF THE OUTPUT VALUE OF MODE = 0 OR 1 THEN C RNORM IS THE L2 NORM OF THE VECTOR C (YDATA(I) - F(XDATA(I)), I = 1,NDATA). C C WORKING ARRAYS.. C C W(*),IW(*) THESE ARRAYS ARE RESPECTIVELY TYPED C REAL AND INTEGER. THEIR REQUIRED C LENGTHS ARE SPECIFIED AS INPUT PARAMETERS C IN IW(1), IW(2) NOTED ABOVE. IT IS ASSUMED C THAT W(1),...,W(NB) HAVE NOT BEEN MODIFIED C IF BFIT( ) IS BEING RECALLED FOR THE SAME C KNOTS AND DATA AS BEFORE (I.E., IF WE HAVE C AN OLD PROBLEM). C C C REFERENCE. HANSON R.J., CONSTRAINED LEAST SQUARES CURVE FITTING C TO DISCRETE DATA USING B-SPLINES, A USERS GUIDE. C SANDIA LABS. TECH. REPT. SAND-78-1291, DEC, 1978. C C----------------------------------------------------------------------- C WRITTEN BY C RICHARD J. HANSON C SANDIA LABORATORIES C MODIFIED BY A.H. MORRIS (NSWC) C----------------------------------------------------------------------- REAL BKPT(*), XDATA(NDATA), YDATA(NDATA) REAL XCONST(*), YCONST(*), COEFF(N), W(*) INTEGER NDERIV(*), IW(*) C NBKPT = N + NORD MDG = N + 3 MDW = N + 1 + NCONST C C USAGE IN BFIT0( ) OF W(*).. C C I1,...,I2-1 G(*,*) C C I2,...,I3-1 BF(*,*) C C I3,...,I7-1 W(*,*) C C I7,... WORK(*) FOR BSPVD( ) AND LSEI( ) C I1 = 1 I2 = I1 + MDG*(NORD + 1) I3 = I2 + NORD*NORD I7 = I3 + MDW*(N + 1) C CALL BFIT0 (NDATA, XDATA, YDATA, NORD, NBKPT, BKPT, NCONST, 1 XCONST, YCONST, NDERIV, MODE, COEFF, RNORM, W(I2), 2 W(I1), MDG, W(I3), MDW, W(I7), IW) RETURN END SUBROUTINE BFIT0 (NDATA, XDATA, YDATA, NORD, NBKPT, BKPT, 1 NCONST, XCONST, YCONST, NDERIV, MODE, COEFF, RNORM, 2 BF, G, MDG, W, MDW, WORK, IWORK) C--------------------- REAL BKPT(NBKPT), XDATA(NDATA), YDATA(NDATA) REAL XCONST(*), YCONST(*), COEFF(*) REAL BF(NORD,NORD), G(MDG,*), W(MDW,*), WORK(*) INTEGER NDERIV(*), IWORK(*) C REAL PRGOPT(7) LOGICAL BAND, NEW C GO TO 100 C 10 IF (.NOT. BAND) GO TO 20 CALL BNDSL (1, G, MDG, NORD, IP, IR, COEFF, N, RNORM, IERR) IF (IERR .EQ. 0) RETURN C C CHECK FURTHER FOR SUFFICIENT STORAGE IN WORKING ARRAYS. C 20 IF (IW1 .LT. LW) GO TO 850 IF (IW2 .LT. INTW1) GO TO 860 GO TO 300 C C SOLVE THE EQUATIONS C 30 CALL LSEI(W, MDW, NEQCON, NP1, NINCON, N, PRGOPT, COEFF, RNORME, * RNORM, MODE, WORK, IWORK) IWORK(1) = IW1 IWORK(2) = IW2 RETURN C----------------------------------------------------------------------- C INITIALIZE-VARIABLES-AND-ANALYZE-INPUT C----------------------------------------------------------------------- 100 N = NBKPT - NORD IF (NORD .LT. 1 .OR. NORD .GT. N) GO TO 800 IF (NDATA .LT. 1 .OR. NCONST .LT. 0) GO TO 810 C C CHECK THE BREAK POINTS C IF (MODE .NE. 0) GO TO 120 M = NBKPT - 1 DO 110 I = 1,M IF (BKPT(I) .GT. BKPT(I+1)) GO TO 820 110 CONTINUE C C AMOUNT OF STORAGE ALLOCATED FOR W(*),IW(*) C 120 IW1 = IWORK(1) IW2 = IWORK(2) NB = (N + 3)*(NORD + 1) + NORD*NORD LW = NB IF (IW1 .LT. NB) GO TO 850 C C COMPUTE THE AMOUNT OF STORAGE NEEDED FOR LSEI C NEQCON = 0 NINCON = 0 IF (NCONST .EQ. 0) GO TO 150 DO 140 I = 1,NCONST L = NDERIV(I) IF (L .LT. 0) GO TO 140 ITYPE = L - 4*(L/4) IF (ITYPE .GT. 1) GO TO 130 NINCON = NINCON + 1 GO TO 140 130 NEQCON = NEQCON + 1 140 CONTINUE C 150 NP1 = N + 1 L = NP1 LW = NB + (L+NCONST)*L + 2*(NEQCON+L) + (NINCON+L) + * (NINCON+2)*(L+6) INTW1 = NINCON + 2*L C C CHECK THE XCONST(*) ARRAY C XMIN = BKPT(NORD) XMAX = BKPT(NP1) IF (NCONST .EQ. 0) GO TO 170 DO 160 I = 1,NCONST IF (XCONST(I) .LT. XMIN .OR. XCONST(I) .GT. XMAX) * GO TO 840 160 CONTINUE C C INITIALIZE PARAMETERS C 170 NEW = MODE .EQ. 0 BAND = NCONST .EQ. 0 MODE = 0 NORDM1 = NORD - 1 NORDP1 = NORD + 1 C C DEFINE THE OPTION VECTOR FOR USE IN LSEI( ) C C INCREASE THE RANK DETERMINATION TOLERANCES C FOR BOTH EQUALITY CONSTRAINT EQUATIONS AND C LEAST SQUARES EQUATIONS. C PRGOPT(1) = 4 PRGOPT(2) = 4 PRGOPT(3) = 1.E-3 C PRGOPT(4) = 7 PRGOPT(5) = 5 PRGOPT(6) = 1.E-3 C PRGOPT(7) = 1 C IF (.NOT. NEW) GO TO 260 C C CHECK THE XDATA(*) ARRAY C IF (XDATA(1) .LT. XMIN .OR. XDATA(NDATA) .GT. XMAX) * GO TO 830 IF (NDATA .EQ. 1) GO TO 200 C M = NDATA - 1 DO 180 I = 1,M IF (XDATA(I) .GE. XDATA(I+1)) GO TO 830 180 CONTINUE C C INITIALIZE PARAMETERS OF BANDED MATRIX PROCESSOR, BNDACC( ) C 200 MT = 0 IP = 1 IR = 1 IDATA = 1 ILEFT = NORD C 210 IF (IDATA .GT. NDATA) GO TO 250 XVAL = XDATA(IDATA) IF (ILEFT .EQ. N) GO TO 230 C C WHEN INTERVAL CHANGES, PROCESS EQUATIONS IN THE LAST BLOCK. C IP1 = ILEFT + 1 IF (XVAL .LT. BKPT(IP1)) GO TO 230 INTRVL = ILEFT - NORDM1 CALL BNDACC (G, MDG, NORD, IP, IR, MT, INTRVL) MT = 0 C C MOVE POINTER UP SO THAT XVAL .GE. BKPT(ILEFT). C DO 220 I = IP1,N IF (XVAL .LT. BKPT(I)) GO TO 230 220 ILEFT = I C C OBTAIN B-SPLINE FUNCTION VALUE C 230 J = 0 CALL BSPVB (BKPT, NORD, NORD, J, XVAL, ILEFT, BF) C C MOVE ROW INTO PLACE C IROW = IR + MT MT = MT + 1 CALL SCOPY (NORD, BF, 1, G(IROW,1), MDG) G(IROW,NORDP1) = YDATA(IDATA) C C WHEN STAGING WORK AREA IS EXHAUSTED, PROCESS ROWS C IF (IROW .NE. MDG - 1) GO TO 240 INTRVL = ILEFT - NORDM1 CALL BNDACC (G, MDG, NORD, IP, IR, MT, INTRVL) MT = 0 240 IDATA = IDATA + 1 GO TO 210 C C PROCESS BLOCK OF EQUATIONS C 250 INTRVL = ILEFT - NORDM1 CALL BNDACC (G, MDG, NORD, IP, IR, MT, INTRVL) C C LAST CALL TO ADJUST BLOCK POSITIONING C G(IR,1) = 0.0 CALL SCOPY (NORDP1, G(IR,1), 0, G(IR,1), MDG) CALL BNDACC (G, MDG, NORD, IP, IR, 1, NP1) C 260 DO 270 I = 1,N BAND = BAND .AND. G(I,1) .NE. 0.0 270 CONTINUE GO TO 10 C----------------------------------------------------------------------- C ANALYZE CONSTRAINT INDICATORS FOR EQUALITY CONSTRAINTS C----------------------------------------------------------------------- 300 IDATA = 0 NEQCON = 0 C 310 IDATA = IDATA + 1 IF (IDATA .GT. NCONST) GO TO 400 L = NDERIV(IDATA) IF (L .LT. 0) GO TO 310 IDERIV = L/4 ITYPE = L - 4*IDERIV C IF (ITYPE .LT. 2) GO TO 310 NEQCON = NEQCON + 1 XVAL = XCONST(IDATA) ILEFT = NORD IF (NORD .EQ. N) GO TO 330 DO 320 I = NORDP1,N IF (XVAL .LT. BKPT(I)) GO TO 330 320 ILEFT = I 330 CALL BSPVD (BKPT, NORD, XVAL, ILEFT, BF, NORD, IDERIV + 1, WORK) W(NEQCON,1) = 0.0 CALL SCOPY (N, W(NEQCON,1), 0, W(NEQCON,1), MDW) INTRVL = ILEFT - NORDM1 CALL SCOPY (NORD, BF(1,IDERIV+1), 1, W(NEQCON,INTRVL), MDW) IF (ITYPE .NE. 2) GO TO 340 W(NEQCON,NP1) = YCONST(IDATA) GO TO 310 C 340 W(NEQCON,NP1) = 0.0 YVAL = YCONST(IDATA) I = IDATA IF (YVAL .LT. XMIN .OR. YVAL .GT. XMAX) GO TO 840 ILEFT = NORD IF (NORD .EQ. N) GO TO 360 DO 350 I = NORDP1,N IF (YVAL .LT. BKPT(I)) GO TO 360 350 ILEFT = I 360 CALL BSPVD (BKPT, NORD, YVAL, ILEFT, BF, NORD, IDERIV + 1, WORK) INTRVL = ILEFT - NORDM1 CALL SAXPY (NORD, -1.0, BF(1,IDERIV+1), 1, W(NEQCON,INTRVL), MDW) GO TO 310 C----------------------------------------------------------------------- C TRANSFER-LEAST-SQUARES DATA C----------------------------------------------------------------------- 400 DO 410 I = 1,NP1 IROW = I + NEQCON W(IROW,1) = 0.0 CALL SCOPY (N, W(IROW,1), 0, W(IROW,1), MDW) CALL SCOPY (MIN0(NP1-I,NORD), G(I,1), MDG, W(IROW,I), MDW) W(IROW,NP1) = G(I,NORDP1) 410 CONTINUE C----------------------------------------------------------------------- C ANALYZE CONSTRAINT INDICATORS FOR INEQUALITY CONSTRAINTS C----------------------------------------------------------------------- IDATA = 0 NINCON = 0 C 500 IDATA = IDATA + 1 IF (IDATA .GT. NCONST) GO TO 30 L = NDERIV(IDATA) IF (L .LT. 0) GO TO 500 IDERIV = L/4 ITYPE = L - 4*IDERIV C IF (ITYPE .GT. 1) GO TO 500 NINCON = NINCON + 1 XVAL = XCONST(IDATA) ILEFT = NORD IF (NORD .EQ. N) GO TO 520 DO 510 I = NORDP1,N IF (XVAL .LT. BKPT(I)) GO TO 520 510 ILEFT = I 520 CALL BSPVD (BKPT, NORD, XVAL, ILEFT, BF, NORD, IDERIV + 1, WORK) IROW = NEQCON + NP1 + NINCON W(IROW,1) = 0.0 CALL SCOPY (N, W(IROW,1), 0, W(IROW,1), MDW) INTRVL = ILEFT - NORDM1 CALL SCOPY (NORD, BF(1,IDERIV+1), 1, W(IROW,INTRVL), MDW) W(IROW,NP1) = YCONST(IDATA) IF (ITYPE .NE. 0) GO TO 500 W(IROW,NP1) = -W(IROW,NP1) CALL SSCAL(NORD, -1.0, W(IROW,INTRVL), MDW) GO TO 500 C----------------------------------------------------------------------- C ERROR RETURN C----------------------------------------------------------------------- C EITHER NORD .LT. 1 OR NORD .GT. N. 800 MODE = -1 RETURN C EITHER NDATA .LT. 1 OR NCONST .LT. 0. 810 MODE = -2 RETURN C THE SEQUENCE OF KNOTS IS NOT NONDECREASING. 820 MODE = -3 RETURN C XDATA(*) IS NOT AN INCREASING SEQUENCE IN THE C CLOSED INTERVAL (BKPT(1),BKPT(N+1)). 830 MODE = -4 RETURN C THE I-TH CONSTRAINT IS INCORRECT FOR THE C VALUE OF I STORED IN IWORK(2). 840 IWORK(2) = I MODE = -5 RETURN C INSUFF. STORAGE FOR W(*). IWORK(1) HAS BEEN SET C TO THE AMOUNT OF STORAGE NEEDED BY W(*). 850 IWORK(1) = LW MODE = -6 RETURN C INSUFF. STORAGE FOR IW(*). IWORK(2) HAS BEEN SET C TO THE AMOUNT OF STORAGE NEEDED BY IW(*). 860 IWORK(2) = INTW1 MODE = -7 RETURN END SUBROUTINE BNDACC (G,MDG,NB,IP,IR,MT,JT) C C***AUTHOR LAWSON, C. L., (JPL) C HANSON, R. J., (SNLA) C C***PURPOSE SOLVE THE LEAST SQUARES PROBLEM AX = B FOR BANDED C MATRICES A USING SEQUENTIAL ACCUMULATION OF ROWS OF C THE DATA MATRIX. EXACTLY ONE RIGHT-HANDED SIDE VECTOR C IS PERMITTED. C***DESCRIPTION C C THESE SUBROUTINES SOLVE THE LEAST SQUARES PROBLEM AX = B FOR C BANDED MATRICES A USING SEQUENTIAL ACCUMULATION OF ROWS OF THE C DATA MATRIX. EXACTLY ONE RIGHT-HAND SIDE VECTOR IS PERMITTED. C C THESE SUBROUTINES ARE INTENDED FOR THE TYPE OF LEAST SQUARES C SYSTEMS THAT ARISE IN APPLICATIONS SUCH AS CURVE OR SURFACE C FITTING OF DATA. THE LEAST SQUARES EQUATIONS ARE ACCUMULATED AND C PROCESSED USING ONLY PART OF THE DATA. THIS REQUIRES A CERTAIN C USER INTERACTION DURING THE SOLUTION OF AX = B. C C SPECIFICALLY, SUPPOSE THE DATA MATRIX (A B) IS ROW PARTITIONED C INTO Q SUBMATRICES. LET (E F) BE THE T-TH ONE OF THESE C SUBMATRICES WHERE E = (0 C 0). HERE THE DIMENSION OF E IS MT BY N C AND THE DIMENSION OF C IS MT BY NB. THE VALUE OF NB IS THE C BANDWIDTH OF A. THE DIMENSIONS OF THE LEADING BLOCK OF ZEROS IN E C ARE MT BY JT-1. C C THE USER OF THE SUBROUTINE BNDACC PROVIDES MT,JT,C AND F FOR C T=1,...,Q. NOT ALL OF THIS DATA MUST BE SUPPLIED AT ONCE. C C FOLLOWING THE PROCESSING OF THE VARIOUS BLOCKS (E F), THE MATRIX C (A B) HAS BEEN TRANSFORMED TO THE FORM (R D) WHERE R IS UPPER C TRIANGULAR AND BANDED WITH BANDWIDTH NB. THE LEAST SQUARES C SYSTEM RX = D IS THEN EASILY SOLVED USING BACK SUBSTITUTION BY C EXECUTING THE STATEMENT CALL BNDSL(1,...). THE SEQUENCE OF C VALUES FOR JT MUST BE NONDECREASING. THIS MAY REQUIRE SOME C PRELIMINARY INTERCHANGES OF ROWS AND COLUMNS OF THE MATRIX A. C C THE PRIMARY REASON FOR THESE SUBROUTINES IS THAT THE TOTAL C PROCESSING CAN TAKE PLACE IN A WORKING ARRAY OF DIMENSION MU BY C NB+1. AN ACCEPTABLE VALUE FOR MU IS C C MU = MAX(MT + N + 1), C C WHERE N IS THE NUMBER OF UNKNOWNS. C C HERE THE MAXIMUM IS TAKEN OVER ALL VALUES OF MT FOR T=1,...,Q. C NOTICE THAT MT CAN BE TAKEN TO BE A SMALL AS ONE, SHOWING THAT C MU CAN BE AS SMALL AS N+2. THE SUBPROGRAM BNDACC PROCESSES THE C ROWS MORE EFFICIENTLY IF MU IS LARGE ENOUGH SO THAT EACH NEW C BLOCK (C F) HAS A DISTINCT VALUE OF JT. C C THE FOUR PRINCIPLE PARTS OF THESE ALGORITHMS ARE OBTAINED BY THE C FOLLOWING CALL STATEMENTS C C CALL BNDACC(...) INTRODUCE NEW BLOCKS OF DATA. C C CALL BNDSL(1,...)COMPUTE SOLUTION VECTOR AND LENGTH OF C RESIDUAL VECTOR. C C CALL BNDSL(2,...)GIVEN ANY ROW VECTOR H SOLVE YR = H FOR THE C ROW VECTOR Y. C C CALL BNDSL(3,...)GIVEN ANY COLUMN VECTOR W SOLVE RZ = W FOR C THE COLUMN VECTOR Z. C C THE DOTS IN THE ABOVE CALL STATEMENTS INDICATE ADDITIONAL C ARGUMENTS THAT WILL BE SPECIFIED IN THE FOLLOWING PARAGRAPHS. C C THE USER MUST DIMENSION THE ARRAY APPEARING IN THE CALL LIST.. C G(MDG,NB+1) C C DESCRIPTION OF CALLING SEQUENCE FOR BNDACC.. C C THE ENTIRE SET OF PARAMETERS FOR BNDACC ARE C C INPUT.. C C G(*,*) THE WORKING ARRAY INTO WHICH THE USER WILL C PLACE THE MT BY NB+1 BLOCK (C F) IN ROWS IR C THROUGH IR+MT-1, COLUMNS 1 THROUGH NB+1. C SEE DESCRIPTIONS OF IR AND MT BELOW. C C MDG THE NUMBER OF ROWS IN THE WORKING ARRAY C G(*,*). THE VALUE OF MDG SHOULD BE .GE. MU. C THE VALUE OF MU IS DEFINED IN THE ABSTRACT C OF THESE SUBPROGRAMS. C C NB THE BANDWIDTH OF THE DATA MATRIX A. C C IP SET BY THE USER TO THE VALUE 1 BEFORE THE C FIRST CALL TO BNDACC. ITS SUBSEQUENT VALUE C IS CONTROLLED BY BNDACC TO SET UP FOR THE C NEXT CALL TO BNDACC. C C IR INDEX OF THE ROW OF G(*,*) WHERE THE USER IS C TO PLACE THE NEW BLOCK OF DATA (C F). SET BY C THE USER TO THE VALUE 1 BEFORE THE FIRST CALL C TO BNDACC. ITS SUBSEQUENT VALUE IS CONTROLLED C BY BNDACC. A VALUE OF IR .GT. MDG IS CONSIDERED C AN ERROR. C C MT,JT SET BY THE USER TO INDICATE RESPECTIVELY THE C NUMBER OF NEW ROWS OF DATA IN THE BLOCK AND C THE INDEX OF THE FIRST NONZERO COLUMN IN THAT C SET OF ROWS (E F) = (0 C 0 F) BEING PROCESSED. C C OUTPUT.. C C G(*,*) THE WORKING ARRAY WHICH WILL CONTAIN THE C PROCESSED ROWS OF THAT PART OF THE DATA C MATRIX WHICH HAS BEEN PASSED TO BNDACC. C C IP,IR THE VALUES OF THESE ARGUMENTS ARE ADVANCED BY C BNDACC TO BE READY FOR STORING AND PROCESSING C A NEW BLOCK OF DATA IN G(*,*). C C C REMARKS.. C C TO OBTAIN THE UPPER TRIANGULAR MATRIX AND TRANSFORMED RIGHT-HAND C SIDE VECTOR D SO THAT THE SUPER DIAGONALS OF R FORM THE COLUMNS C OF G(*,*), EXECUTE THE FOLLOWING FORTRAN STATEMENTS. C C NBP1=NB+1 C C DO 10 J=1, NBP1 C C 10 G(IR,J) = 0.E0 C C MT=1 C C JT=N+1 C C CALL BNDACC(G,MDG,NB,IP,IR,MT,JT) C C***REFERENCES C. L. LAWSON AND R. J. HANSON, C SOLVING LEAST SQUARE PROBLEMS,PRENCTICE-HALL, INC C (1974), CHAPTER 27 C DIMENSION G(MDG,*) C C C ALG. STEPS 1-4 ARE PERFORMED EXTERNAL TO THIS SUBROUTINE. C NBP1 = NB + 1 IF (MT .LE. 0 .OR. NB .LE. 0) RETURN C ALG. STEP 5 IF (JT .EQ. IP) GO TO 70 C ALG. STEPS 6-7 IF (JT .LE. IR) GO TO 30 C ALG. STEPS 8-9 DO 11 I = 1,MT IG1 = JT + MT - I IG2 = IR + MT - I DO 10 J = 1,NBP1 G(IG1,J) = G(IG2,J) 10 CONTINUE 11 CONTINUE C ALG. STEP 10 IE = JT - IR DO 21 I = 1,IE IG = IR + I - 1 DO 20 J = 1,NBP1 G(IG,J) = 0.0 20 CONTINUE 21 CONTINUE C ALG. STEP 11 IR = JT C ALG. STEP 12 30 MU = MIN0(NB - 1, IR - IP - 1) IF (MU .EQ. 0) GO TO 60 C ALG. STEP 13 DO 50 L = 1,MU C ALG. STEP 14 K = MIN0(L, JT - IP) C ALG. STEP 15 LP1 = L + 1 IG = IP + L DO 40 I = LP1,NB JG = I - K G(IG,JG) = G(IG,I) 40 CONTINUE C ALG. STEP 16 DO 45 I = 1,K JG = NBP1 - I G(IG,JG) = 0.0 45 CONTINUE 50 CONTINUE C ALG. STEP 17 60 IP = JT C ALG. STEPS 18-19 70 MH = IR + MT - IP KH = MIN0(NBP1, MH) C ALG. STEP 20 DO 80 I = 1,KH CALL H12 (1,I,MAX0(I+1,IR-IP+1),MH,G(IP,I),1,RHO, 1 G(IP,I+1),1,MDG,NBP1-I) 80 CONTINUE C ALG. STEP 21 IR = IP + KH C ALG. STEP 22 IF (KH .LT. NBP1) GO TO 100 C ALG. STEP 23 DO 90 I = 1,NB G(IR-1,I) = 0.0 90 CONTINUE C ALG. STEP 24 100 CONTINUE C ALG. STEP 25 RETURN END SUBROUTINE BNDSL (MODE,G,MDG,NB,IP,IR,X,N,RNORM,IERR) C C***AUTHOR LAWSON, C. L., (JPL) C HANSON, R. J., (SNLA) C C***PURPOSE SOLVE THE LEAST SQUARES PROBLEM AX = B FOR BANDED C MATRICES A USING SEQUENTIAL ACCUMULATION OF ROWS OF C THE DATA MATRIX. EXACTLY ONE RIGHT-HANDED SIDE VECTOR C IS PERMITTED. C C THESE SUBROUTINES SOLVE THE LEAST SQUARES PROBLEM AX = B FOR C BANDED MATRICES A USING SEQUENTIAL ACCUMULATION OF ROWS OF THE C DATA MATRIX. EXACTLY ONE RIGHT-HAND SIDE VECTOR IS PERMITTED. C C THESE SUBROUTINES ARE INTENDED FOR THE TYPE OF LEAST SQUARES C SYSTEMS THAT ARISE IN APPLICATIONS SUCH AS CURVE OR SURFACE C FITTING OF DATA. THE LEAST SQUARES EQUATIONS ARE ACCUMULATED AND C PROCESSED USING ONLY PART OF THE DATA. THIS REQUIRES A CERTAIN C USER INTERACTION DURING THE SOLUTION OF AX = B. C C SPECIFICALLY, SUPPOSE THE DATA MATRIX (A B) IS ROW PARTITIONED C INTO Q SUBMATRICES. LET (E F) BE THE T-TH ONE OF THESE C SUBMATRICES WHERE E = (0 C 0). HERE THE DIMENSION OF E IS MT BY N C AND THE DIMENSION OF C IS MT BY NB. THE VALUE OF NB IS THE C BANDWIDTH OF A. THE DIMENSIONS OF THE LEADING BLOCK OF ZEROS IN E C ARE MT BY JT-1. C C THE USER OF THE SUBROUTINE BNDACC PROVIDES MT,JT,C AND F FOR C T=1,...,Q. NOT ALL OF THIS DATA MUST BE SUPPLIED AT ONCE. C C FOLLOWING THE PROCESSING OF THE VARIOUS BLOCKS (E F), THE MATRIX C (A B) HAS BEEN TRANSFORMED TO THE FORM (R D) WHERE R IS UPPER C TRIANGULAR AND BANDED WITH BANDWIDTH NB. THE LEAST SQUARES C SYSTEM RX = D IS THEN EASILY SOLVED USING BACK SUBSTITUTION BY C EXECUTING THE STATEMENT CALL BNDSL(1,...). THE SEQUENCE OF C VALUES FOR JT MUST BE NONDECREASING. THIS MAY REQUIRE SOME C PRELIMINARY INTERCHANGES OF ROWS AND COLUMNS OF THE MATRIX A. C C THE PRIMARY REASON FOR THESE SUBROUTINES IS THAT THE TOTAL C PROCESSING CAN TAKE PLACE IN A WORKING ARRAY OF DIMENSION MU BY C NB+1. AN ACCEPTABLE VALUE FOR MU IS C C MU = MAX(MT + N + 1), C C WHERE N IS THE NUMBER OF UNKNOWNS. C C HERE THE MAXIMUM IS TAKEN OVER ALL VALUES OF MT FOR T=1,...,Q. C NOTICE THAT MT CAN BE TAKEN TO BE A SMALL AS ONE, SHOWING THAT C MU CAN BE AS SMALL AS N+2. THE SUBPROGRAM BNDACC PROCESSES THE C ROWS MORE EFFICIENTLY IF MU IS LARGE ENOUGH SO THAT EACH NEW C BLOCK (C F) HAS A DISTINCT VALUE OF JT. C C THE FOUR PRINCIPLE PARTS OF THESE ALGORITHMS ARE OBTAINED BY THE C FOLLOWING CALL STATEMENTS C C CALL BNDACC(...) INTRODUCE NEW BLOCKS OF DATA. C C CALL BNDSL(1,...)COMPUTE SOLUTION VECTOR AND LENGTH OF C RESIDUAL VECTOR. C C CALL BNDSL(2,...)GIVEN ANY ROW VECTOR H SOLVE YR = H FOR THE C ROW VECTOR Y. C C CALL BNDSL(3,...)GIVEN ANY COLUMN VECTOR W SOLVE RZ = W FOR C THE COLUMN VECTOR Z. C C THE DOTS IN THE ABOVE CALL STATEMENTS INDICATE ADDITIONAL C ARGUMENTS THAT WILL BE SPECIFIED IN THE FOLLOWING PARAGRAPHS. C C THE USER MUST DIMENSION THE ARRAY APPEARING IN THE CALL LIST.. C G(MDG,NB+1) C C DESCRIPTION OF CALLING SEQUENCE FOR BNDSL.. C C THE USER MUST DIMENSION THE ARRAYS APPEARING IN THE CALL LIST.. C C G(MDG,NB+1), X(N) C C THE ENTIRE SET OF PARAMETERS FOR BNDSL ARE C C INPUT.. C C MODE SET BY THE USER TO ONE OF THE VALUES 1, 2, OR C 3. THESE VALUES RESPECTIVELY INDICATE THAT C THE SOLUTION OF AX = B, YR = H OR RZ = W IS C REQUIRED. C C G(*,*),MDG, THESE ARGUMENTS ALL HAVE THE SAME MEANING AND C NB,IP,IR CONTENTS AS FOLLOWING THE LAST CALL TO BNDACC. C C X(*) WITH MODE=2 OR 3 THIS ARRAY CONTAINS, C RESPECTIVELY, THE RIGHT-SIDE VECTORS H OR W OF C THE SYSTEMS YR = H OR RZ = W. C C N THE NUMBER OF VARIABLES IN THE SOLUTION C VECTOR. IF ANY OF THE N DIAGONAL TERMS ARE C ZERO THE SUBROUTINE BNDSL PRINTS AN C APPROPRIATE MESSAGE. THIS CONDITION IS C CONSIDERED AN ERROR. C C OUTPUT.. C C X(*) THIS ARRAY CONTAINS THE SOLUTION VECTORS X, C Y OR Z OF THE SYSTEMS AX = B, YR = H OR C RZ = W DEPENDING ON THE VALUE OF MODE=1, C 2 OR 3. C C RNORM IF MODE=1 RNORM IS THE EUCLIDEAN LENGTH OF THE C RESIDUAL VECTOR AX-B. WHEN MODE=2 OR 3 RNORM C IS SET TO ZERO. C C IERR IERR = 0 IF THE SOLUTION WAS OBTAINED. C IERR = 1 IF THE PROBLEM CANNOT BE SOLVED. C C C***REFERENCES C. L. LAWSON AND R. J. HANSON, C SOLVING LEAST SQUARE PROBLEMS,PRENCTICE-HALL, INC C (1974), CHAPTER 27 C DIMENSION G(MDG,*),X(N) C IERR = 0 RNORM = 0.0 GO TO (10,90,50), MODE C ********************* MODE = 1 C ALG. STEP 26 10 DO 20 J = 1,N X(J) = G(J, NB+1) 20 CONTINUE RSQ = 0.0 NP1 = N + 1 IRM1 = IR - 1 IF (NP1 .GT. IRM1) GO TO 40 DO 30 J = NP1,IRM1 RSQ = RSQ + G(J, NB+1)**2 30 CONTINUE RNORM = SQRT(RSQ) 40 CONTINUE C ********************* MODE = 3 C ALG. STEP 27 50 DO 80 II = 1,N I = N + 1 - II C ALG. STEP 28 S = 0.0 L = MAX0(0, I - IP) C ALG. STEP 29 IF (I .EQ. N) GO TO 70 C ALG. STEP 30 IE = MIN0(N + 1 - I, NB) DO 60 J = 2,IE JG = J + L IX = I - 1 + J S = S + G(I,JG)*X(IX) 60 CONTINUE C ALG. STEP 31 70 IF (G(I,L+1) .EQ. 0.0) GO TO 130 X(I) = (X(I) - S)/G(I,L+1) 80 CONTINUE C ALG. STEP 32 RETURN C ********************* MODE = 2 90 DO 120 J = 1,N S = 0.0 IF (J .EQ. 1) GO TO 110 I1 = MAX0(1, J - NB + 1) I2 = J - 1 DO 100 I = I1,I2 L = J - I + 1 + MAX0(0, I - IP) S = S + X(I)*G(I,L) 100 CONTINUE 110 L = MAX0(0, J - IP) IF (G(J,L+1) .EQ. 0.0) GO TO 130 X(J) = (X(J) - S)/G(J,L+1) 120 CONTINUE RETURN C C A ZERO DIAGONAL TERM OCCURS C 130 IERR = 1 RETURN END SUBROUTINE SPFIT2 (X, WX, MX, Y, WY, MY, Z, KZ, XBREAK, NX, * YBREAK, NY, F, S, T, WK, NUM, IERR) C----------------------------------------------------------------------- C C WEIGHTED LEAST SQUARES BICUBIC SPLINE FITTING C C ----------------- C C THE PIECEWISE POLYNOMIALS CONSIDERED ARE TENSOR PRODUCTS OF C B-SPLINES, HAVING THE FORM C C M N C F(X,Y) = SUM SUM A U (X) V (Y) C I=1 J=1 IJ I J C C WHERE M = NX + 2 AND N = NY + 2, AND U AND V ARE B-SPLINE C BASIS FUNCTIONS OF DEGREE 3. LET I J C C M C G (X) = SUM A U (X) C J I=1 IJ I C C FOR J = 1,...,N. THEN G (X),...,G (X) ARE CUBIC SPLINES AND C 1 N C N C F(X,Y) = SUM G (X) V (Y) . C J=1 J J C C THE ARRAYS S AND T DEFINED IN THE CODE ARE THE KNOT SEQUENCES C FOR THE B-SPLINES U (X) AND V (Y). C I J C----------------------------------------------------------------------- C WRITTEN BY C ALFRED H. MORRIS, JR. C NAVAL SURFACE WARFARE CENTER C DAHLGREN, VIRGINIA C----------------------------------------------------------------------- REAL X(MX), WX(MX), Y(MY), WY(MY), Z(KZ, MY) REAL XBREAK(NX), YBREAK(NY), F(*) REAL S(*), T(*), WK(NUM) C--------------------- C REAL F(4*NX*NY), S(NX + 6), T(NY + 6) C--------------------- IF (NX .LT. 2) GO TO 100 IF (NY .LT. 2) GO TO 120 M = NX + 2 N = NY + 2 L = MAX0(M*N, M*MY + 5*MAX0(M,N)) IF (NUM .LT. L) GO TO 130 C C DEFINE THE KNOT SQUENCES C S(1) = XBREAK(1) S(2) = XBREAK(1) S(3) = XBREAK(1) S(4) = XBREAK(1) DO 10 I = 2,NX IF (XBREAK(I - 1) .GE. XBREAK(I)) GO TO 100 S(I + 3) = XBREAK(I) 10 CONTINUE S(NX + 4) = XBREAK(NX) S(NX + 5) = XBREAK(NX) S(NX + 6) = XBREAK(NX) C T(1) = YBREAK(1) T(2) = YBREAK(1) T(3) = YBREAK(1) T(4) = YBREAK(1) DO 20 J = 2,NY IF (YBREAK(J - 1) .GE. YBREAK(J)) GO TO 120 T(J + 3) = YBREAK(J) 20 CONTINUE T(NY + 4) = YBREAK(NY) T(NY + 5) = YBREAK(NY) T(NY + 6) = YBREAK(NY) C C OBTAIN THE B-SPLINE COEFFICIENTS OF THE BIVARIATE C LEAST SQUARES FIT AND STORE THEM IN WK. C CALL BSLSQ2 (X, WX, MX, Y, WY, MY, Z, KZ, S, M, 4, * T, N, 4, F, M, WK, NUM, IERR) IF (IERR .LT. 0) GO TO 110 IERR = 0 C L = M*N DO 30 I = 1,L WK(I) = F(I) 30 CONTINUE C C COMPUTE THE N CUBIC SPLINES G (X) AND THEIR FIRST C J C DERIVATIVES AT THE POINTS IN XBREAK. THEN STORE THE C DERIVATIVES IN WK. (THE VALUES OF THE SPLINES WILL C BE IN THE LATTER HALF OF F.) C NU = NX*NY L = 2*NU + 1 CALL CSPP (S, WK, M, M, N, F(L), N, F(1), N) C IMAX = N*NX DO 40 I = 1,IMAX WK(I) = F(I) 40 CONTINUE C C COMPUTE THE VALUES OF THE BISPLINE AND THEIR PARTIAL C DERIVATIVES WITH RESPECT TO Y. THE RESULTS ARE STORED C IN THE FIRST HALF OF F. C LD = NU + 1 CALL CSPP (T, F(L), N, N, NX, F(1), NX, F(LD), NX) C C COMPUTE THE REMAINING PARTIAL DERIVATIVES AND STORE C THE RESULTS IN THE LATTER HALF OF F. C LD = L + NU CALL CSPP (T, WK, N, N, NX, F(L), NX, F(LD), NX) RETURN C C ERROR RETURN C 100 IERR = 1 RETURN 110 IERR = 2 IF (IERR .EQ. -2) IERR = 4 RETURN 120 IERR = 3 RETURN 130 IERR = 5 WK(1) = L RETURN END SUBROUTINE CSPP (T, A, KA, M, N, Z, KZ, DZ, KDZ) C----------------------------------------------------------------------- C C COMPUTATION OF N CUBIC SPLINES AND THEIR FIRST C DERIVATIVES AT THE KNOTS T(4),...,T(M+1). THE C CUBIC SPLINES ARE REPRESENTED IN B-SPLINE FORM. C C --------------- C C INPUT ... C C T KNOT SEQUENCE OF LENGTH M+4. C A M X N MATRIX. EACH COLUMN OF A IS A SEQUENCE C OF M B-SPLINE COEFFICIENTS FOR A CUBIC SPLINE. C KA THE NUMBER OF ROWS SPECIFIED IN THE CALLING C PROGRAM FOR A. IT IS ASSUMED THAT KA .GE. M. C M DIMENSION OF THE B-SPLINE SPACE. C N NUMBER OF CUBIC SPLINES CONSIDERED. C KZ THE NUMBER OF ROWS SPECIFIED IN THE CALLING C PROGRAM FOR Z. IT IS ASSUMED THAT KZ .GE. N. C KDZ THE NUMBER OF ROWS SPECIFIED IN THE CALLING C PROGRAM FOR DZ. IT IS ASSUMED THAT KZ .GE. N. C C OUTPUT ... C C Z N X (M-2) MATRIX WHERE Z(J,I) = VALUE OF J-TH CUBIC C SPLINE AT THE POINT T(I+3) FOR I = 1,...,M-2. C C DZ N X (M-2) MATRIX WHERE DZ(J,I) = FIRST DERIVATIVE OF C THE J-TH CUBIC SPLINE EVALUATED AT THE POINT T(I+3). C C----------------------------------------------------------------------- REAL T(*), A(KA,N), Z(KZ,*), DZ(KDZ,*) REAL C(4), WK(4,5) C K = 4 MP1 = M + 1 DO 70 MU = 1,N C C OBTAING THE VALUES FOR THE MU-TH CUBIC SPLINE C L = 0 DO 60 LEFT = K,M L = L + 1 C C COMPUTE THE COEFFICIENTS FOR THE L-TH C POLYNOMIAL FORMING THE CUBIC SPLINE. THE C COEFFICIENTS ARE STORED IN C. THIS CODE C IS FROM THE SUBROUTINE BSPP. C DO 10 J = 1,K JJ = LEFT - K + J WK(J,1) = A(JJ,MU) 10 CONTINUE C DO 21 J = 1,3 JP1 = J + 1 KMJ = K - J DO 20 I = 1,KMJ IL = I + LEFT ILKJ = IL - KMJ DIFF = T(IL) - T(ILKJ) WK(I,JP1) = (WK(I+1,J) - WK(I,J))/DIFF 20 CONTINUE 21 CONTINUE C WK(1,5) = 1.0 X = T(LEFT) C(4) = WK(1,4) R = 1.0 DO 50 J = 1,3 JP1 = J + 1 S = 0.0 DO 30 I = 1,J IL = I + LEFT ILJ = IL - J TERM = WK(I,5)/(T(IL) - T(ILJ)) WK(I,5) = S + (T(IL) - X)*TERM S = (X - T(ILJ))*TERM 30 CONTINUE WK(JP1,5) = S C S = 0.0 KMJ = K - J DO 40 I = 1,JP1 S = S + WK(I,KMJ)*WK(I,5) 40 CONTINUE R = (R*FLOAT(KMJ))/FLOAT(J) C(KMJ) = R*S 50 CONTINUE C C STORE THE VALUE OF THE SPLINE AND ITS C FIRST DERIVATIVE AT THE KNOT T(LEFT) C Z(MU,L) = C(1) DZ(MU,L) = C(2) 60 CONTINUE C C COMPUTE THE SPLINE AND ITS FIRST DERIVATIVE C AT THE KNOT T(M+1) C L = L + 1 DEL = T(MP1) - T(M) Z(MU,L) = ((C(4)*DEL + C(3))*DEL + C(2))*DEL + C(1) DZ(MU,L) = (3.0*C(4)*DEL + 2.0*C(3))*DEL + C(2) 70 CONTINUE RETURN END SUBROUTINE CSURF (IDER, JDER, X, MX, Y, MY, Z, KZ, S, M, T, N, * F, KF, F1, KF1, F2, KF2, F12, KF12) C----------------------------------------------------------------------- C C EVALUATION OR DIFFERENTIATION OF A BICUBIC C SPLINE OVER A GRID C C----------------------------------------------------------------------- REAL X(MX), Y(MY), Z(KZ,MY) REAL S(M), T(N), F(KF,N), F1(KF1,N), F2(KF2,N), F12(KF12,N) C IF (IDER .GT. 3 .OR. JDER .GT. 3) GO TO 400 MM1 = M - 1 NM1 = N - 1 C IOLD = 0 JOLD = 0 DO 360 L = 1,MY YY = Y(L) IF (YY .LT. T(2)) GO TO 10 IF (YY .GE. T(NM1)) GO TO 20 IF (L .EQ. 1) GO TO 30 IF (YY - Y(L-1)) 30,50,40 C 10 J = 1 GO TO 50 20 J = NM1 GO TO 50 30 J = INTRVL (YY, T, N) GO TO 50 C C LINEAR FORWARD SEARCH C 40 IF (YY .LT. T(J + 1)) GO TO 50 J = J + 1 GO TO 40 C 50 JP1 = J + 1 DT = T(JP1) - T(J) C DO 350 K = 1,MX XX = X(K) IF (XX .LT. S(2)) GO TO 100 IF (XX .GE. S(MM1)) GO TO 110 IF (K .EQ. 1) GO TO 120 IF (XX - X(K-1)) 120,130,140 C 100 I = 1 IF (I .EQ. IOLD .AND. J .EQ. JOLD) GO TO 210 GO TO 200 110 I = MM1 IF (I .EQ. IOLD .AND. J .EQ. JOLD) GO TO 210 GO TO 200 120 I = INTRVL (XX, S, M) IF (I .EQ. IOLD .AND. J .EQ. JOLD) GO TO 210 GO TO 200 130 Z(K,L) = Z(K-1,L) GO TO 350 C C LINEAR FORWARD SEARCH C 140 IF (XX .LT. S(I + 1)) GO TO 210 150 I = I + 1 IF (XX .GE. S(I + 1)) GO TO 150 C C COMPUTATION OF THE JDER-TH DERIVATIVE OF C F(S(I),Y), D1F(S(I),Y), F(S(I+1),Y), AND C D1F(S(I+1),Y) AT THE POINT YY. C 200 IOLD = I IP1 = I + 1 DS = S(IP1) - S(I) C D = (F(I,JP1) - F(I,J))/DT A = F2(I,J) + F2(I,JP1) B = (-A - F2(I,J) + 3.0*D)/DT C = (A - D - D)/(DT*DT) C D = (F(IP1,JP1) - F(IP1,J))/DT A = F2(IP1,J) + F2(IP1,JP1) B1 = (-A - F2(IP1,J) + 3.0*D)/DT C1 = (A - D - D)/(DT*DT) C D = (F1(I,JP1) - F1(I,J))/DT A = F12(I,J) + F12(I,JP1) B2 = (-A - F12(I,J) + 3.0*D)/DT C2 = (A - D - D)/(DT*DT) C D = (F1(IP1,JP1) - F1(IP1,J))/DT A = F12(IP1,J) + F12(IP1,JP1) B3 = (-A - F12(IP1,J) + 3.0*D)/DT C3 = (A - D - D)/(DT*DT) C 210 DY = YY - T(J) IF (JDER .EQ. 0) GO TO 220 IF (JDER - 2) 230,240,250 C 220 FI = ((C*DY + B)*DY + F2(I,J))*DY + F(I,J) FIP1 = ((C1*DY + B1)*DY + F2(IP1,J))*DY + F(IP1,J) DFI = ((C2*DY + B2)*DY + F12(I,J))*DY + F1(I,J) DFIP1 = ((C3*DY + B3)*DY + F12(IP1,J))*DY + F1(IP1,J) GO TO 300 C 230 FI = (3.0*C*DY + 2.0*B)*DY + F2(I,J) FIP1 = (3.0*C1*DY + 2.0*B1)*DY + F2(IP1,J) DFI = (3.0*C2*DY + 2.0*B2)*DY + F12(I,J) DFIP1 = (3.0*C3*DY + 2.0*B3)*DY + F12(IP1,J) GO TO 300 C 240 FI = 6.0*C*DY + 2.0*B FIP1 = 6.0*C1*DY + 2.0*B1 DFI = 6.0*C2*DY + 2.0*B2 DFIP1 = 6.0*C3*DY + 2.0*B3 GO TO 300 C 250 FI = 6.0*C FIP1 = 6.0*C1 DFI = 6.0*C2 DFIP1 = 6.0*C3 C C COMPUTATION OF THE IDER-TH DERIVATIVE C AT THE POINT XX. C 300 D = (FIP1 - FI)/DS A = DFI + DFIP1 BX = (-A - DFI + 3.0*D)/DS CX = (A - D - D)/(DS*DS) C DX = XX - S(I) IF (IDER .EQ. 0) GO TO 310 IF (IDER - 2) 320,330,340 C 310 Z(K,L) = ((CX*DX + BX)*DX + DFI)*DX + FI GO TO 350 320 Z(K,L) = (3.0*CX*DX + 2.0*BX)*DX + DFI GO TO 350 330 Z(K,L) = 6.0*CX*DX + 2.0*BX GO TO 350 340 Z(K,L) = 6.0*CX C 350 CONTINUE JOLD = J 360 CONTINUE RETURN C C CASE WHEN THE RESULTS ARE ZERO. C 400 DO 420 L = 1,MY DO 410 K = 1,MX Z(K,L) = 0.0 410 CONTINUE 420 CONTINUE RETURN END SUBROUTINE CSURF1 (IDER, JDER, X, MX, Y, MY, Z, KZ, S, M, T, N, F) C----------------------------------------------------------------------- C C EVALUATION OR DIFFERENTIATION OF A BICUBIC C SPLINE OVER A GRID C C----------------------------------------------------------------------- REAL X(MX), Y(MY), Z(KZ,MY) REAL S(M), T(N), F(M,N,4) C CALL CSURF (IDER, JDER, X, MX, Y, MY, Z, KZ, S, M, T, N, F, M, * F(1,1,3), M, F(1,1,2), M, F(1,1,4), M) RETURN END SUBROUTINE CSRF (IDER, JDER, X, MX, Y, MY, Z, KZ, S, M, T, N, * F, KF, F1, KF1, F2, KF2, F12, KF12) C----------------------------------------------------------------------- C C EVALUATION OR DIFFERENTIATION OF A BICUBIC C SPLINE OVER A GRID C C----------------------------------------------------------------------- REAL X(MX), Y(MY), Z(KZ,MY) REAL S(M), T(N), F(KF,N), F1(KF1,N), F2(KF2,N), F12(KF12,N) C IF (IDER .GT. 3 .OR. JDER .GT. 3) GO TO 400 MM1 = M - 1 NM1 = N - 1 C IOLD = 0 JOLD = 0 DO 360 L = 1,MY YY = Y(L) IF (YY .LT. T(2)) GO TO 10 IF (YY .GE. T(NM1)) GO TO 20 IF (L .EQ. 1) GO TO 30 IF (YY - Y(L-1)) 30,50,40 C 10 J = 1 GO TO 50 20 J = NM1 GO TO 50 30 J = INTRVL (YY, T, N) GO TO 50 C C LINEAR FORWARD SEARCH C 40 IF (YY .LT. T(J + 1)) GO TO 50 J = J + 1 GO TO 40 C 50 JP1 = J + 1 DT = T(JP1) - T(J) C DO 350 K = 1,MX XX = X(K) IF (XX .LT. S(2)) GO TO 100 IF (XX .GE. S(MM1)) GO TO 110 IF (K .EQ. 1) GO TO 120 IF (XX - X(K-1)) 120,130,140 C 100 I = 1 IF (I .EQ. IOLD .AND. J .EQ. JOLD) GO TO 210 GO TO 200 110 I = MM1 IF (I .EQ. IOLD .AND. J .EQ. JOLD) GO TO 210 GO TO 200 120 I = INTRVL (XX, S, M) IF (I .EQ. IOLD .AND. J .EQ. JOLD) GO TO 210 GO TO 200 130 Z(K,L) = Z(K-1,L) GO TO 350 C C LINEAR FORWARD SEARCH C 140 IF (XX .LT. S(I + 1)) GO TO 210 150 I = I + 1 IF (XX .GE. S(I + 1)) GO TO 150 C C COMPUTATION OF THE JDER-TH DERIVATIVE OF C F(S(I),Y), D1F(S(I),Y), F(S(I+1),Y), AND C D1F(S(I+1),Y) AT THE POINT YY. C 200 IOLD = I IP1 = I + 1 DS = S(IP1) - S(I) C D = (F(I,JP1) - F(I,J))/DT A = D - DT*(2.0*F2(I,J) + F2(I,JP1))/6.0 C = (F2(I,JP1) - F2(I,J))/(6.0*DT) C D = (F(IP1,JP1) - F(IP1,J))/DT A1 = D - DT*(2.0*F2(IP1,J) + F2(IP1,JP1))/6.0 C1 = (F2(IP1,JP1) - F2(IP1,J))/(6.0*DT) C D = (F1(I,JP1) - F1(I,J))/DT A2 = D - DT*(2.0*F12(I,J) + F12(I,JP1))/6.0 C2 = (F12(I,JP1) - F12(I,J))/(6.0*DT) C D = (F1(IP1,JP1) - F1(IP1,J))/DT A3 = D - DT*(2.0*F12(IP1,J) + F12(IP1,JP1))/6.0 C3 = (F12(IP1,JP1) - F12(IP1,J))/(6.0*DT) C 210 DY = YY - T(J) IF (JDER .EQ. 0) GO TO 220 IF (JDER - 2) 230,240,250 C 220 FI = ((C*DY + 0.5*F2(I,J))*DY + A)*DY + F(I,J) FIP1 = ((C1*DY + 0.5*F2(IP1,J))*DY + A1)*DY + F(IP1,J) DFI = ((C2*DY + 0.5*F12(I,J))*DY + A2)*DY + F1(I,J) DFIP1 = ((C3*DY + 0.5*F12(IP1,J))*DY + A3)*DY + F1(IP1,J) GO TO 300 C 230 FI = (3.0*C*DY + F2(I,J))*DY + A FIP1 = (3.0*C1*DY + F2(IP1,J))*DY + A1 DFI = (3.0*C2*DY + F12(I,J))*DY + A2 DFIP1 = (3.0*C3*DY + F12(IP1,J))*DY + A3 GO TO 300 C 240 FI = 6.0*C*DY + F2(I,J) FIP1 = 6.0*C1*DY + F2(IP1,J) DFI = 6.0*C2*DY + F12(I,J) DFIP1 = 6.0*C3*DY + F12(IP1,J) GO TO 300 C 250 FI = 6.0*C FIP1 = 6.0*C1 DFI = 6.0*C2 DFIP1 = 6.0*C3 C C COMPUTATION OF THE IDER-TH DERIVATIVE C AT THE POINT XX. C 300 D = (FIP1 - FI)/DS AX = D - DS*(2.0*DFI + DFIP1)/6.0 CX = (DFIP1 - DFI)/(6.0*DS) C DX = XX - S(I) IF (IDER .EQ. 0) GO TO 310 IF (IDER - 2) 320,330,340 C 310 Z(K,L) = ((CX*DX + 0.5*DFI)*DX + AX)*DX + FI GO TO 350 320 Z(K,L) = (3.0*CX*DX + DFI)*DX + AX GO TO 350 330 Z(K,L) = 6.0*CX*DX + DFI GO TO 350 340 Z(K,L) = 6.0*CX C 350 CONTINUE JOLD = J 360 CONTINUE RETURN C C CASE WHEN THE RESULTS ARE ZERO. C 400 DO 420 L = 1,MY DO 410 K = 1,MX Z(K,L) = 0.0 410 CONTINUE 420 CONTINUE RETURN END SUBROUTINE CSRF2 (IDER, JDER, X, MX, Y, MY, Z, KZ, S, M, T, N, * F, KF, DDF) C----------------------------------------------------------------------- C C EVALUATION OR DIFFERENTIATION OF A BICUBIC C SPLINE OVER A GRID C C----------------------------------------------------------------------- REAL X(MX), Y(MY), Z(KZ,MY) REAL S(M), T(N), F(KF,N), DDF(M,N,3) C CALL CSRF (IDER, JDER, X, MX, Y, MY, Z, KZ, S, M, T, N, F, KF, * DDF(1,1,2), M, DDF, M, DDF(1,1,3), M) RETURN END SUBROUTINE SURF (M,N,X,Y,Z,IZ,OPT,ZP,TEMP,SIGMA,IERR) C INTEGER M,N,IZ,IERR REAL X(M),Y(N),Z(IZ,N),OPT(*),ZP(M,N,*),TEMP(*),SIGMA C C FROM THE SPLINE UNDER TENSION PACKAGE C CODED BY A. K. CLINE AND R. J. RENKA C DEPARTMENT OF COMPUTER SCIENCES C UNIVERSITY OF TEXAS AT AUSTIN C C MODIFIED BY ALFRED H. MORRIS C NAVAL SURFACE WEAPONS CENTER C DAHLGREN VIRGINIA C C THIS SUBROUTINE DETERMINES THE PARAMETERS NECESSARY TO C COMPUTE AN INTERPOLATORY SURFACE PASSING THROUGH A RECT- C ANGULAR GRID OF FUNCTIONAL VALUES. THE SURFACE DETERMINED C CAN BE REPRESENTED AS THE TENSOR PRODUCT OF SPLINES UNDER C TENSION. THE X- AND Y-PARTIAL DERIVATIVES AROUND THE C BOUNDARY AND THE X-Y-PARTIAL DERIVATIVES AT THE FOUR C CORNERS MAY BE SPECIFIED OR OMITTED. FOR ACTUAL MAPPING C OF POINTS ONTO THE SURFACE IT IS NECESSARY TO CALL THE C FUNCTION SURF2. C C ON INPUT-- C C M IS THE NUMBER OF GRID LINES IN THE X-DIRECTION, I. E. C LINES PARALLEL TO THE Y-AXIS (M .GE. 2). C C N IS THE NUMBER OF GRID LINES IN THE Y-DIRECTION, I. E. C LINES PARALLEL TO THE X-AXIS (N .GE. 2). C C X IS AN ARRAY OF THE M X-COORDINATES OF THE GRID LINES C IN THE X-DIRECTION. THESE SHOULD BE STRICTLY INCREASING. C C Y IS AN ARRAY OF THE N Y-COORDINATES OF THE GRID LINES C IN THE Y-DIRECTION. THESE SHOULD BE STRICTLY INCREASING. C C Z IS AN ARRAY OF THE M * N FUNCTIONAL VALUES AT THE GRID C POINTS, I. E. Z(I,J) CONTAINS THE FUNCTIONAL VALUE AT C (X(I),Y(J)) FOR I = 1,...,M AND J = 1,...,N. C C IZ IS THE ROW DIMENSION OF THE MATRIX Z USED IN THE C CALLING PROGRAM (IZ .GE. M). C C OPT IS AN OPTION VECTOR. IF NO BOUNDARY CONDITIONS ARE C TO BE IMPOSED ON THE SURFACE THEN LET OPT BE OF LENGTH 1 C AND SET OPT(1)=0. OTHERWISE, SEE THE DESCRIPTION OF SURF C IN THE NSWC LIBRARY MANUAL. C C ZP IS AN ARRAY OF AT LEAST 3*M*N LOCATIONS. C C TEMP IS AN ARRAY OF AT LEAST N+N+M LOCATIONS WHICH IS C USED FOR SCRATCH STORAGE. C C SIGMA CONTAINS THE TENSION FACTOR. THIS VALUE INDICATES C THE CURVINESS DESIRED. IF ABS(SIGMA) IS NEARLY ZERO C (E. G. .001) THE RESULTING SURFACE IS APPROXIMATELY THE C TENSOR PRODUCT OF CUBIC SPLINES. IF ABS(SIGMA) IS LARGE C (E. G. 50.) THE RESULTING SURFACE IS APPROXIMATELY C BI-LINEAR. IF SIGMA EQUALS ZERO TENSOR PRODUCTS OF C CUBIC SPLINES RESULT. A STANDARD VALUE FOR SIGMA IS C APPROXIMATELY 1. IN ABSOLUTE VALUE. C C ON OUTPUT-- C C ZP CONTAINS THE VALUES OF THE XX-, YY-, AND XXYY-PARTIAL C DERIVATIVES OF THE SURFACE AT THE GIVEN NODES. C C IERR CONTAINS AN ERROR FLAG, C = 0 FOR NORMAL RETURN, C = 1 IF N IS LESS THAN 2 OR M IS LESS THAN 2, C = 2 IF THE X-VALUES OR Y-VALUES ARE NOT STRICTLY C INCREASING, C = 3 THE OPTION VECTOR HAS AN ERROR. C C THIS SUBROUTINE REFERENCES PACKAGE MODULES CEEZ, TERMS, C AND SNHCSH. C C----------------------------------------------------------- C INTEGER IND(8),LOC(8),NUM(8) DATA NUM(5)/1/, NUM(6)/1/, NUM(7)/1/, NUM(8)/1/ C MM1 = M-1 MP1 = M+1 NM1 = N-1 NP1 = N+1 NPM = N+M IERR = 0 IF (N .LE. 1 .OR. M .LE. 1) GO TO 46 IF (Y(N) .LE. Y(1)) GO TO 47 C C PROCESS THE OPTION VECTOR C NUM(1) = N NUM(2) = N NUM(3) = M NUM(4) = M IND(1) = 0 IND(2) = 0 IND(3) = 0 IND(4) = 0 IND(5) = 0 IND(6) = 0 IND(7) = 0 IND(8) = 0 C L = 1 100 KEY = OPT(L) IF (KEY) 48,110,101 101 IF (KEY .GT. 8) GO TO 48 IND(KEY) = 1 L = L+1 LOC(KEY) = L L = L + NUM(KEY) GO TO 100 C C DENORMALIZE TENSION FACTOR IN Y-DIRECTION C 110 SIGMAY = ABS(SIGMA)*FLOAT(N-1)/(Y(N)-Y(1)) C C OBTAIN Y-PARTIAL DERIVATIVES ALONG Y = Y(1) C IF (IND(3) .EQ. 0) GO TO 2 L = LOC(3) DO 1 I = 1,M ZP(I,1,1) = OPT(L) 1 L = L+1 GO TO 5 2 DELY1 = Y(2)-Y(1) DELY2 = DELY1+DELY1 IF (N .GT. 2) DELY2 = Y(3)-Y(1) IF (DELY1 .LE. 0. .OR. DELY2 .LE. DELY1) GO TO 47 CALL CEEZ (DELY1,DELY2,SIGMAY,C1,C2,C3,N) DO 3 I = 1,M 3 ZP(I,1,1) = C1*Z(I,1)+C2*Z(I,2) IF (N .EQ. 2) GO TO 5 DO 4 I = 1,M 4 ZP(I,1,1) = ZP(I,1,1)+C3*Z(I,3) C C OBTAIN Y-PARTIAL DERIVATIVES ALONG Y = Y(N) C 5 IF (IND(4) .EQ. 0) GO TO 7 L = LOC(4) DO 6 I = 1,M NPI = N+I TEMP(NPI) = OPT(L) 6 L = L+1 GO TO 10 7 DELYN = Y(N)-Y(NM1) DELYNM = DELYN+DELYN IF (N .GT. 2) DELYNM = Y(N)-Y(N-2) IF (DELYN .LE. 0. .OR. DELYNM .LE. DELYN) GO TO 47 CALL CEEZ (-DELYN,-DELYNM,SIGMAY,C1,C2,C3,N) DO 8 I = 1,M NPI = N+I 8 TEMP(NPI) = C1*Z(I,N)+C2*Z(I,NM1) IF (N .EQ. 2) GO TO 10 DO 9 I = 1,M NPI = N+I 9 TEMP(NPI) = TEMP(NPI)+C3*Z(I,N-2) 10 IF (X(M) .LE. X(1)) GO TO 47 C C DENORMALIZE TENSION FACTOR IN X-DIRECTION C SIGMAX = ABS(SIGMA)*FLOAT(M-1)/(X(M)-X(1)) C C OBTAIN X-PARTIAL DERIVATIVES ALONG X = X(1) C IF (IND(1) .EQ. 0) GO TO 12 L = LOC(1) DO 11 J = 1,N ZP(1,J,2) = OPT(L) 11 L = L+1 IF (IND(5)+IND(7) .EQ. 2) GO TO 15 12 DELX1 = X(2)-X(1) DELX2 = DELX1+DELX1 IF (M .GT. 2) DELX2 = X(3)-X(1) IF (DELX1 .LE. 0. .OR. DELX2 .LE. DELX1) GO TO 47 CALL CEEZ (DELX1,DELX2,SIGMAX,C1,C2,C3,M) IF (IND(1) .EQ. 1) GO TO 15 DO 13 J = 1,N 13 ZP(1,J,2) = C1*Z(1,J)+C2*Z(2,J) IF (M .EQ. 2) GO TO 15 DO 14 J = 1,N 14 ZP(1,J,2) = ZP(1,J,2)+C3*Z(3,J) C C OBTAIN X-Y-PARTIAL DERIVATIVE AT (X(1),Y(1)) C 15 IF (IND(5) .EQ. 0) GO TO 16 L = LOC(5) ZP(1,1,3) = OPT(L) GO TO 17 16 ZP(1,1,3) = C1*ZP(1,1,1)+C2*ZP(2,1,1) IF (M .GT. 2) ZP(1,1,3) = ZP(1,1,3)+C3*ZP(3,1,1) C C OBTAIN X-Y-PARTIAL DERIVATIVE AT (X(1),Y(N)) C 17 IF (IND(7) .EQ. 0) GO TO 18 L = LOC(7) ZXY1NS = OPT(L) GO TO 19 18 ZXY1NS = C1*TEMP(N+1)+C2*TEMP(N+2) IF (M .GT. 2) ZXY1NS = ZXY1NS+C3*TEMP(N+3) C C OBTAIN X-PARTIAL DERIVATIVE ALONG X = X(M) C 19 IF (IND(2) .EQ. 0) GO TO 21 L = LOC(2) DO 20 J = 1,N NPMPJ = NPM+J TEMP(NPMPJ) = OPT(L) 20 L = L+1 21 IF (IND(6)+IND(8) .EQ. 2) GO TO 24 DELXM = X(M)-X(MM1) DELXMM = DELXM+DELXM IF (M .GT. 2) DELXMM = X(M)-X(M-2) IF (DELXM .LE. 0. .OR. DELXMM .LE. DELXM) GO TO 47 CALL CEEZ (-DELXM,-DELXMM,SIGMAX,C1,C2,C3,M) IF (IND(2) .EQ. 1) GO TO 24 DO 22 J = 1,N NPMPJ = NPM+J 22 TEMP(NPMPJ) = C1*Z(M,J)+C2*Z(MM1,J) IF (M .EQ. 2) GO TO 24 DO 23 J = 1,N NPMPJ = NPM+J 23 TEMP(NPMPJ) = TEMP(NPMPJ)+C3*Z(M-2,J) C C OBTAIN X-Y-PARTIAL DERIVATIVE AT (X(M),Y(1)) C 24 IF (IND(6) .EQ. 0) GO TO 25 L = LOC(6) ZP(M,1,3) = OPT(L) GO TO 26 25 ZP(M,1,3) = C1*ZP(M,1,1)+C2*ZP(MM1,1,1) IF (M .GT. 2) ZP(M,1,3) = ZP(M,1,3)+C3*ZP(M-2,1,1) C C OBTAIN X-Y-PARTIAL DERIVATIVE AT (X(M),Y(N)) C 26 IF (IND(8) .EQ. 0) GO TO 27 L = LOC(8) ZXYMNS = OPT(L) GO TO 28 27 ZXYMNS = C1*TEMP(NPM)+C2*TEMP(NPM-1) IF (M .GT. 2) ZXYMNS = ZXYMNS+C3*TEMP(NPM-2) C C SET UP RIGHT HAND SIDES AND TRIDIAGONAL SYSTEM FOR Y-GRID C PERFORM FORWARD ELIMINATION C 28 DEL1 = Y(2)-Y(1) IF (DEL1 .LE. 0.) GO TO 47 DELI = 1./DEL1 DO 29 I = 1,M 29 ZP(I,2,1) = DELI*(Z(I,2)-Z(I,1)) ZP(1,2,3) = DELI*(ZP(1,2,2)-ZP(1,1,2)) ZP(M,2,3) = DELI*(TEMP(NPM+2)-TEMP(NPM+1)) CALL TERMS (DIAG1,SDIAG1,SIGMAY,DEL1) DIAGI = 1./DIAG1 DO 30 I = 1,M 30 ZP(I,1,1) = DIAGI*(ZP(I,2,1)-ZP(I,1,1)) ZP(1,1,3) = DIAGI*(ZP(1,2,3)-ZP(1,1,3)) ZP(M,1,3) = DIAGI*(ZP(M,2,3)-ZP(M,1,3)) TEMP(1) = DIAGI*SDIAG1 IF (N .EQ. 2) GO TO 34 DO 33 J = 2,NM1 JM1 = J-1 JP1 = J+1 NPMPJ = NPM+J DEL2 = Y(JP1)-Y(J) IF (DEL2 .LE. 0.) GO TO 47 DELI = 1./DEL2 DO 31 I = 1,M 31 ZP(I,JP1,1) = DELI*(Z(I,JP1)-Z(I,J)) ZP(1,JP1,3) = DELI*(ZP(1,JP1,2)-ZP(1,J,2)) ZP(M,JP1,3) = DELI*(TEMP(NPMPJ+1)-TEMP(NPMPJ)) CALL TERMS (DIAG2,SDIAG2,SIGMAY,DEL2) DIAGIN = 1./(DIAG1+DIAG2-SDIAG1*TEMP(JM1)) DO 32 I = 1,M 32 ZP(I,J,1) = DIAGIN*(ZP(I,JP1,1)-ZP(I,J,1)- * SDIAG1*ZP(I,JM1,1)) ZP(1,J,3) = DIAGIN*(ZP(1,JP1,3)-ZP(1,J,3)- * SDIAG1*ZP(1,JM1,3)) ZP(M,J,3) = DIAGIN*(ZP(M,JP1,3)-ZP(M,J,3)- * SDIAG1*ZP(M,JM1,3)) TEMP(J) = DIAGIN*SDIAG2 DIAG1 = DIAG2 33 SDIAG1 = SDIAG2 34 DIAGIN = 1./(DIAG1-SDIAG1*TEMP(NM1)) DO 35 I = 1,M NPI = N+I 35 ZP(I,N,1) = DIAGIN*(TEMP(NPI)-ZP(I,N,1)- * SDIAG1*ZP(I,NM1,1)) ZP(1,N,3) = DIAGIN*(ZXY1NS-ZP(1,N,3)- * SDIAG1*ZP(1,NM1,3)) TEMP(N) = DIAGIN*(ZXYMNS-ZP(M,N,3)- * SDIAG1*ZP(M,NM1,3)) C C PERFORM BACK SUBSTITUTION C DO 37 J = 2,N JBAK = NP1-J JBAKP1 = JBAK+1 T = TEMP(JBAK) DO 36 I = 1,M 36 ZP(I,JBAK,1) = ZP(I,JBAK,1)-T*ZP(I,JBAKP1,1) ZP(1,JBAK,3) = ZP(1,JBAK,3)-T*ZP(1,JBAKP1,3) 37 TEMP(JBAK) = ZP(M,JBAK,3)-T*TEMP(JBAKP1) C C SET UP RIGHT HAND SIDES AND TRIDIAGONAL SYSTEM FOR X-GRID C PERFORM FORWARD ELIMINATION C DEL1 = X(2)-X(1) IF (DEL1 .LE. 0.) GO TO 47 DELI = 1./DEL1 DO 38 J = 1,N ZP(2,J,2) = DELI*(Z(2,J)-Z(1,J)) 38 ZP(2,J,3) = DELI*(ZP(2,J,1)-ZP(1,J,1)) CALL TERMS (DIAG1,SDIAG1,SIGMAX,DEL1) DIAGI = 1./DIAG1 DO 39 J = 1,N ZP(1,J,2) = DIAGI*(ZP(2,J,2)-ZP(1,J,2)) 39 ZP(1,J,3) = DIAGI*(ZP(2,J,3)-ZP(1,J,3)) TEMP(N+1) = DIAGI*SDIAG1 IF (M .EQ. 2) GO TO 43 DO 42 I = 2,MM1 IM1 = I-1 IP1 = I+1 NPI = N+I DEL2 = X(IP1)-X(I) IF (DEL2 .LE. 0.) GO TO 47 DELI = 1./DEL2 DO 40 J = 1,N ZP(IP1,J,2) = DELI*(Z(IP1,J)-Z(I,J)) 40 ZP(IP1,J,3) = DELI*(ZP(IP1,J,1)-ZP(I,J,1)) CALL TERMS (DIAG2,SDIAG2,SIGMAX,DEL2) DIAGIN = 1./(DIAG1+DIAG2-SDIAG1*TEMP(NPI-1)) DO 41 J = 1,N ZP(I,J,2) = DIAGIN*(ZP(IP1,J,2)-ZP(I,J,2)- * SDIAG1*ZP(IM1,J,2)) 41 ZP(I,J,3) = DIAGIN*(ZP(IP1,J,3)-ZP(I,J,3)- * SDIAG1*ZP(IM1,J,3)) TEMP(NPI) = DIAGIN*SDIAG2 DIAG1 = DIAG2 42 SDIAG1 = SDIAG2 43 DIAGIN = 1./(DIAG1-SDIAG1*TEMP(NPM-1)) DO 44 J = 1,N NPMPJ = NPM+J ZP(M,J,2) = DIAGIN*(TEMP(NPMPJ)-ZP(M,J,2)- * SDIAG1*ZP(MM1,J,2)) 44 ZP(M,J,3) = DIAGIN*(TEMP(J)-ZP(M,J,3)- * SDIAG1*ZP(MM1,J,3)) C C PERFORM BACK SUBSTITUTION C DO 45 I = 2,M IBAK = MP1-I IBAKP1 = IBAK+1 NPIBAK = N+IBAK T = TEMP(NPIBAK) DO 45 J = 1,N ZP(IBAK,J,2) = ZP(IBAK,J,2)-T*ZP(IBAKP1,J,2) 45 ZP(IBAK,J,3) = ZP(IBAK,J,3)-T*ZP(IBAKP1,J,3) RETURN C C TOO FEW POINTS C 46 IERR = 1 RETURN C C POINTS NOT STRICTLY INCREASING C 47 IERR = 2 RETURN C C THE OPTION VECTOR HAS AN ERROR C 48 IERR = 3 RETURN END FUNCTION SURF2 (XX,YY,M,N,X,Y,Z,IZ,ZP,SIGMA) C INTEGER M,N,IZ REAL XX,YY,X(M),Y(N),Z(IZ,N),ZP(M,N,*),SIGMA C C FROM THE SPLINE UNDER TENSION PACKAGE C CODED BY A. K. CLINE AND R. J. RENKA C DEPARTMENT OF COMPUTER SCIENCES C UNIVERSITY OF TEXAS AT AUSTIN C C THIS FUNCTION INTERPOLATES A SURFACE AT A GIVEN COORDINATE C PAIR USING A BI-SPLINE UNDER TENSION. THE SUBROUTINE SURF1 C SHOULD BE CALLED EARLIER TO DETERMINE CERTAIN NECESSARY C PARAMETERS. C C ON INPUT-- C C XX AND YY CONTAIN THE X- AND Y-COORDINATES OF THE POINT C TO BE MAPPED ONTO THE INTERPOLATING SURFACE. C C M AND N CONTAIN THE NUMBER OF GRID LINES IN THE X- AND C Y-DIRECTIONS, RESPECTIVELY, OF THE RECTANGULAR GRID C WHICH SPECIFIED THE SURFACE. C C X AND Y ARE ARRAYS CONTAINING THE X- AND Y-GRID VALUES, C RESPECTIVELY, EACH IN INCREASING ORDER. C C Z IS A MATRIX CONTAINING THE M * N FUNCTIONAL VALUES C CORRESPONDING TO THE GRID VALUES (I. E. Z(I,J) IS THE C SURFACE VALUE AT THE POINT (X(I),Y(J)) FOR I = 1,...,M C AND J = 1,...,N). C C IZ CONTAINS THE ROW DIMENSION OF THE ARRAY Z AS DECLARED C IN THE CALLING PROGRAM. C C ZP IS AN ARRAY OF 3*M*N LOCATIONS STORED WITH THE C VARIOUS SURFACE DERIVATIVE INFORMATION DETERMINED BY C SURF1. C C AND C C SIGMA CONTAINS THE TENSION FACTOR (ITS SIGN IS IGNORED). C C THE PARAMETERS M, N, X, Y, Z, IZ, ZP, AND SIGMA SHOULD BE C INPUT UNALTERED FROM THE OUTPUT OF SURF1. C C ON OUTPUT-- C C SURF2 CONTAINS THE INTERPOLATED SURFACE VALUE. C C NONE OF THE INPUT PARAMETERS ARE ALTERED. C C THIS FUNCTION REFERENCES PACKAGE MODULES INTRVL AND C SNHCSH. C C----------------------------------------------------------- C C INLINE ONE DIMENSIONAL CUBIC SPLINE INTERPOLATION C HERMZ (F1,F2,FP1,FP2) = (F2*DEL1+F1*DEL2)/DELS-DEL1* * DEL2*(FP2*(DEL1+DELS)+ * FP1*(DEL2+DELS))/ * (6.*DELS) C C INLINE ONE DIMENSIONAL SPLINE UNDER TENSION INTERPOLATION C HERMNZ (F1,F2,FP1,FP2,SIGMAP) = (F2*DEL1+F1*DEL2)/DELS * +(FP2*(SINHM1*DEL2-DEL1*(2.*(COSHP1+1.)* * SINHP2+SIGMAP*COSHP1*DEL2)) * +FP1*(SINHM2*DEL1-DEL2*(2.*(COSHP2+1.)* * SINHP1+SIGMAP*COSHP2*DEL1)) * )/(SIGMAP*SIGMAP*DELS*(SINHMS+SIGMAP*DELS)) C C DENORMALIZE TENSION FACTOR IN X AND Y DIRECTION C SIGMAX = ABS(SIGMA)*FLOAT(M-1)/(X(M)-X(1)) SIGMAY = ABS(SIGMA)*FLOAT(N-1)/(Y(N)-Y(1)) C C DETERMINE Y INTERVAL C JM1 = INTRVL (YY,Y,N) J = JM1+1 C C DETERMINE X INTERVAL C IM1 = INTRVL (XX,X,M) I = IM1+1 DEL1 = YY-Y(JM1) DEL2 = Y(J)-YY DELS = Y(J)-Y(JM1) IF (SIGMAY .NE. 0.) GO TO 1 C C PERFORM FOUR INTERPOLATIONS IN Y-DIRECTION C ZIM1 = HERMZ(Z(I-1,J-1),Z(I-1,J),ZP(I-1,J-1,1), * ZP(I-1,J,1)) ZI = HERMZ(Z(I,J-1),Z(I,J),ZP(I,J-1,1),ZP(I,J,1)) ZXXIM1 = HERMZ(ZP(I-1,J-1,2),ZP(I-1,J,2), * ZP(I-1,J-1,3),ZP(I-1,J,3)) ZXXI = HERMZ(ZP(I,J-1,2),ZP(I,J,2), * ZP(I,J-1,3),ZP(I,J,3)) GO TO 2 1 DELP1 = (DEL1+DELS)/2. DELP2 = (DEL2+DELS)/2. CALL SNHCSH (SINHM1,DUMMY,SIGMAY*DEL1,-1) CALL SNHCSH (SINHM2,DUMMY,SIGMAY*DEL2,-1) CALL SNHCSH (SINHMS,DUMMY,SIGMAY*DELS,-1) CALL SNHCSH (SINHP1,DUMMY,SIGMAY*DEL1/2.,-1) CALL SNHCSH (SINHP2,DUMMY,SIGMAY*DEL2/2.,-1) CALL SNHCSH (DUMMY,COSHP1,SIGMAY*DELP1,1) CALL SNHCSH (DUMMY,COSHP2,SIGMAY*DELP2,1) ZIM1 = HERMNZ(Z(I-1,J-1),Z(I-1,J),ZP(I-1,J-1,1), * ZP(I-1,J,1),SIGMAY) ZI = HERMNZ(Z(I,J-1),Z(I,J),ZP(I,J-1,1),ZP(I,J,1), * SIGMAY) ZXXIM1 = HERMNZ(ZP(I-1,J-1,2),ZP(I-1,J,2), * ZP(I-1,J-1,3),ZP(I-1,J,3),SIGMAY) ZXXI = HERMNZ(ZP(I,J-1,2),ZP(I,J,2), * ZP(I,J-1,3),ZP(I,J,3),SIGMAY) C C PERFORM FINAL INTERPOLATION IN X-DIRECTION C 2 DEL1 = XX-X(IM1) DEL2 = X(I)-XX DELS = X(I)-X(IM1) IF (SIGMAX .NE. 0.) GO TO 3 SURF2 = HERMZ(ZIM1,ZI,ZXXIM1,ZXXI) RETURN 3 DELP1 = (DEL1+DELS)/2. DELP2 = (DEL2+DELS)/2. CALL SNHCSH (SINHM1,DUMMY,SIGMAX*DEL1,-1) CALL SNHCSH (SINHM2,DUMMY,SIGMAX*DEL2,-1) CALL SNHCSH (SINHMS,DUMMY,SIGMAX*DELS,-1) CALL SNHCSH (SINHP1,DUMMY,SIGMAX*DEL1/2.,-1) CALL SNHCSH (SINHP2,DUMMY,SIGMAX*DEL2/2.,-1) CALL SNHCSH (DUMMY,COSHP1,SIGMAX*DELP1,1) CALL SNHCSH (DUMMY,COSHP2,SIGMAX*DELP2,1) SURF2 = HERMNZ(ZIM1,ZI,ZXXIM1,ZXXI,SIGMAX) RETURN END SUBROUTINE NSURF2 (DXMIN,DXMAX,MD,DYMIN,DYMAX,ND,DZ, * IDZ,M,N,X,Y,Z,IZ,ZP,WORK,SIGMA) C INTEGER MD,ND,IDZ,M,N,IZ REAL DXMIN,DXMAX,DYMIN,DYMAX,DZ(IDZ,ND),X(M),Y(N), * Z(IZ,N),ZP(M,N,*),WORK(4,MD),SIGMA C C FROM THE SPLINE UNDER TENSION PACKAGE C CODED BY ALAN KAYLOR CLINE C DEPARTMENT OF COMPUTER SCIENCES C UNIVERSITY OF TEXAS AT AUSTIN C C THIS SUBROUTINE MAPS VALUES ONTO A SURFACE AT EVERY POINT C OF A GRID EQUALLY SPACED IN BOTH X AND Y COORDINATES. THE C SURFACE INTERPOLATION IS PERFORMED USING A BI-SPLINE C UNDER TENSION. THE SUBROUTINE SURF1 OR NSURF1 SHOULD BE C CALLED EARLIER TO DETERMINE CERTAIN NECESSARY PARAMETERS. C C ON INPUT-- C C DXMIN AND DXMAX CONTAIN THE LOWER AND UPPER LIMITS, C RESPECTIVELY, OF THE X-COORDINATES OF THE SECOND GRID. C C MD CONTAINS THE NUMBER OF GRID LINES IN THE X DIRECTION C OF THE SECOND GRID (MD .GE. 1). C C DYMIN AND DYMAX CONTAIN THE LOWER AND UPPER LIMITS, C RESPECTIVELY, OF THE Y-COORDINATES OF THE SECOND GRID. C C ND CONTAINS THE NUMBER OF GRID LINES IN THE Y DIRECTION C OF THE SECOND GRID (ND .GE. 1). C C IDZ CONTAINS THE ROW DIMENSION OF THE ARRAY DZ AS C DECLARED IN THE CALLING PROGRAM. C C M AND N CONTAIN THE NUMBER OF GRID LINES IN THE X- AND C Y-DIRECTIONS, RESPECTIVELY, OF THE RECTANGULAR GRID C WHICH SPECIFIED THE SURFACE. C C X AND Y ARE ARRAYS CONTAINING THE X- AND Y-GRID VALUES, C RESPECTIVELY, EACH IN INCREASING ORDER. C C Z IS A MATRIX CONTAINING THE M * N FUNCTIONAL VALUES C CORRESPONDING TO THE GRID VALUES (I. E. Z(I,J) IS THE C SURFACE VALUE AT THE POINT (X(I),Y(J)) FOR I = 1,...,M C AND J = 1,...,N). C C IZ CONTAINS THE ROW DIMENSION OF THE ARRAY Z AS DECLARED C IN THE CALLING PROGRAM. C C ZP IS AN ARRAY OF 3*M*N LOCATIONS STORED WITH THE C VARIOUS SURFACE DERIVATIVE INFORMATION DETERMINED BY C SURF1. C C WORK IS AN ARRAY OF 4*MD LOCATIONS TO BE USED INTERNALLY C FOR WORKSPACE. C C AND C C SIGMA CONTAINS THE TENSION FACTOR (ITS SIGN IS IGNORED). C C THE PARAMETERS M, N, X, Y, Z, IZ, ZP, AND SIGMA SHOULD BE C INPUT UNALTERED FROM THE OUTPUT OF SURF1 OR NSURF1. C C ON OUTPUT-- C C DZ CONTAINS THE MD BY ND ARRAY OF SURFACE VALUES C INTERPOLATED AT THE POINTS OF THE SECOND GRID. C C NONE OF THE INPUT PARAMETERS ARE ALTERED. C C THIS FUNCTION REFERENCES PACKAGE MODULE SNHCSH. C C----------------------------------------------------------- C C DENORMALIZE TENSION FACTOR IN X AND Y DIRECTION C SIGMAX = ABS(SIGMA)*FLOAT(M-1)/(X(M)-X(1)) SIGMAY = ABS(SIGMA)*FLOAT(N-1)/(Y(N)-Y(1)) C C FIND INTERVALS OF SECOND X GRID WITH RESPECT TO ORIGINAL X C GRID C DELTDX = 0. IF (MD .GE. 2) DELTDX = (DXMAX-DXMIN)/FLOAT(MD-1) LASTI = 1 DO 3 II = 1,MD XII = DXMIN+FLOAT(II-1)*DELTDX I = LASTI 1 I = I+1 IF (XII .GT. X(I) .AND. I .LT. M) GO TO 1 IM1 = I-1 LASTI = IM1 DEL1 = XII-X(IM1) DEL2 = X(I)-XII DELS = X(I)-X(IM1) WORK(1,II) = DEL2/DELS WORK(2,II) = DEL1/DELS IF (SIGMAX .NE. 0.) GO TO 2 TEMP = -DEL1*DEL2/(6.*DELS) WORK(3,II) = TEMP*(DEL2+DELS) WORK(4,II) = TEMP*(DEL1+DELS) GO TO 3 2 DELP1 = (DEL1+DELS)/2. DELP2 = (DEL2+DELS)/2. CALL SNHCSH (SINHM1,DUMMY,SIGMAX*DEL1,-1) CALL SNHCSH (SINHM2,DUMMY,SIGMAX*DEL2,-1) CALL SNHCSH (SINHMS,DUMMY,SIGMAX*DELS,-1) CALL SNHCSH (SINHP1,DUMMY,SIGMAX*DEL1/2.,-1) CALL SNHCSH (SINHP2,DUMMY,SIGMAX*DEL2/2.,-1) CALL SNHCSH (DUMMY,COSHP1,SIGMAX*DELP1,1) CALL SNHCSH (DUMMY,COSHP2,SIGMAX*DELP2,1) TEMP = SIGMAX*SIGMAX*DELS*(SINHMS+SIGMAX*DELS) WORK(3,II) = (SINHM2*DEL1-DEL2*(2.*(COSHP2+1.)* * SINHP1+SIGMAX*COSHP2*DEL1))/TEMP WORK(4,II) = (SINHM1*DEL2-DEL1*(2.*(COSHP1+1.)* * SINHP2+SIGMAX*COSHP1*DEL2))/TEMP 3 CONTINUE C C FIND INTERVALS OF SECOND Y GRID WITH RESPECT TO ORIGINAL Y C GRID AND PERFORM INTRPOLATION C DELTDY = 0. IF (ND .GE. 2) DELTDY = (DYMAX-DYMIN)/FLOAT(ND-1) LASTJ = 1 DO 8 JJ=1,ND YJJ = DYMIN+FLOAT(JJ-1)*DELTDY J = LASTJ 4 J = J+1 IF (YJJ .GT. Y(J) .AND. J .LT. N) GO TO 4 JM1 = J-1 LASTJ = JM1 DEL1 = YJJ-Y(JM1) DEL2 = Y(J)-YJJ DELS = Y(J)-Y(JM1) C1 = DEL2/DELS C2 = DEL1/DELS IF (SIGMAY .NE. 0.) GO TO 5 TEMP = -DEL1*DEL2/(6.*DELS) C3 = TEMP*(DEL2+DELS) C4 = TEMP*(DEL1+DELS) GO TO 6 5 DELP1 = (DEL1+DELS)/2. DELP2 = (DEL2+DELS)/2. CALL SNHCSH (SINHM1,DUMMY,SIGMAY*DEL1,-1) CALL SNHCSH (SINHM2,DUMMY,SIGMAY*DEL2,-1) CALL SNHCSH (SINHMS,DUMMY,SIGMAY*DELS,-1) CALL SNHCSH (SINHP1,DUMMY,SIGMAY*DEL1/2.,-1) CALL SNHCSH (SINHP2,DUMMY,SIGMAY*DEL2/2.,-1) CALL SNHCSH (DUMMY,COSHP1,SIGMAY*DELP1,1) CALL SNHCSH (DUMMY,COSHP2,SIGMAY*DELP2,1) TEMP = SIGMAY*SIGMAY*DELS*(SINHMS+SIGMAY*DELS) C3 = (SINHM2*DEL1-DEL2*(2.*(COSHP2+1.)* * SINHP1+SIGMAY*COSHP2*DEL1))/TEMP C4 = (SINHM1*DEL2-DEL1*(2.*(COSHP1+1.)* * SINHP2+SIGMAY*COSHP1*DEL2))/TEMP 6 LASTI = 0 DO 8 II=1,MD XII = DXMIN+FLOAT(II-1)*DELTDX I = MAX0 (1, LASTI) 7 I = I+1 IF (XII .GT. X(I) .AND. I .LT. M) GO TO 7 IM1 = I-1 IF (IM1 .EQ. LASTI) GO TO 8 LASTI = IM1 ZIM1 = C1*Z(IM1,JM1)+C2*Z(IM1,J) * +C3*ZP(IM1,JM1,1)+C4*ZP(IM1,J,1) ZI = C1*Z(I,JM1)+C2*Z(I,J) * +C3*ZP(I,JM1,1)+C4*ZP(I,J,1) ZXXIM1 = C1*ZP(IM1,JM1,2)+C2*ZP(IM1,J,2) * +C3*ZP(IM1,JM1,3)+C4*ZP(IM1,J,3) ZXXI = C1*ZP(I,JM1,2)+C2*ZP(I,J,2) * +C3*ZP(I,JM1,3)+C4*ZP(I,J,3) 8 DZ(II,JJ) = WORK(1,II)*ZIM1+WORK(2,II)*ZI * +WORK(3,II)*ZXXIM1+WORK(4,II)*ZXXI RETURN END SUBROUTINE BSTRP2 (X, Y, Z, KZ, TX, NX, KX, TY, NY, KY, * A, KA, WK, L, IFLAG) C----------------------------------------------------------------------- C C PIECEWISE POLYNOMIAL INTERPOLATION IN TWO VARIABLES C C ----------------- C C THE PIECEWISE POLYNOMIALS CONSIDERED ARE TENSOR PRODUCTS OF C B-SPLINES, HAVING THE FORM C C NX NY C F(X,Y) = SUM SUM A U (X) V (Y) C I=1 J=1 IJ I J C C WHERE U AND V ARE ONE-DIMENSIONAL B-SPLINE BASIS FUNCTIONS. C I J C C----------------------------------------------------------------------- C REAL TX(NX + KX), TY(NY + KY) C REAL WK(L) WHERE L = NX*NY + MAX(2*KX*NX, 2*KY*NY) C------------------------- REAL X(NX), Y(NY), Z(KZ,NY) REAL TX(*), TY(*), A(KA,NY), WK(L) C M = NX*NY + 2*MAX0(KX*NX, KY*NY) IF (L .LT. M) GO TO 120 C C COMPUTE THE COEFFICIENTS C IW = NX*NY + 1 CALL BSTRP1 (X, Z, KZ, NX, NY, TX, KX, WK, NY, WK(IW), IFLAG) IF (IFLAG .NE. 0) GO TO 100 CALL BSTRP1 (Y, WK, NY, NY, NX, TY, KY, A, KA, WK(IW), IFLAG) IF (IFLAG .NE. 0) GO TO 110 RETURN C C ERROR RETURN C 100 IFLAG = 1 RETURN 110 IFLAG = 2 RETURN 120 IFLAG = 3 RETURN END SUBROUTINE BSTRP1 (X, Z, KZ, M, N, T, K, A, KA, WORK, IFLAG) C------------------------------------------------------------------- C BSTRP1 COMPUTES B-SPLINE INTERPOLATION COEFFICIENTS FOR C N SETS OF DATA STORED IN THE COLUMNS OF THE ARRAY Z. THE C COEFFICIENTS ARE STORED IN THE ROWS OF A. C C IT IS ASSUMED THAT KZ .GE. M AND KA .GE. N. C------------------------------------------------------------------- C REAL T(M + K), WORK(2*K*M) C----------------------- REAL X(M), Z(KZ,N), T(*), A(KA,M), WORK(*) C C FIRST DATA SET C IFLAG = 1 MP1 = M + 1 CALL BSTRP (X, Z, T, M, K, WORK(1), WORK(MP1), IFLAG) IF (IFLAG .NE. 0) RETURN C DO 10 I = 1,M A(1,I) = WORK(I) 10 CONTINUE IF (N .EQ. 1) RETURN C C REMAINING DATA SETS C DO 30 J = 2,N CALL BSTRP (X, Z(1,J), T, M, K, WORK(1), WORK(MP1), IFLAG) DO 20 I = 1,M A(J,I) = WORK(I) 20 CONTINUE 30 CONTINUE RETURN END SUBROUTINE BSLSQ2 (X, WX, MX, Y, WY, MY, Z, KZ, TX, NX, KX, * TY, NY, KY, A, KA, WK, L, IFLAG) C----------------------------------------------------------------------- C C WEIGHTED LEAST SQUARES FITTING OF PIECEWISE C POLYNOMIALS IN TWO VARIABLES C C ---------------- C C THE PIECEWISE POLYNOMIALS CONSIDERED ARE TENSOR PRODUCTS OF C B-SPLINES, HAVING THE FORM C C NX NY C F(X,Y) = SUM SUM A U (X) V (Y) C I=1 J=1 IJ I J C C WHERE U AND V ARE ONE-DIMENSIONAL B-SPLINE BASIS FUNCTIONS. C I J C C----------------------------------------------------------------------- C REAL TX(NX + KX), TY(NY + KY) C REAL WK(L) WHERE L = NX*MY + MAX((KX+1)*NX,(KY+1)*NY) C------------------------- REAL X(MX), WX(MX), Y(MY), WY(MY), Z(KZ,MY) REAL TX(*), TY(*), A(KA,NY), WK(L) C M = NX*MY + MAX0((KX + 1)*NX,(KY + 1)*NY) IF (L .LT. M) GO TO 120 C C COMPUTE THE COEFFICIENTS C IW = NX*MY + 1 IQ = IW + NX CALL BSLSQ1 (X, WX, MX, Z, KZ, MY, TX, NX, KX, * WK, MY, WK(IW), WK(IQ), IERR) IF (IERR .LT. 0) GO TO 100 C IQ = IW + NY CALL BSLSQ1 (Y, WY, MY, WK, MY, NX, TY, NY, KY, * A, KA, WK(IW), WK(IQ), IFLAG) IF (IFLAG .LT. 0) GO TO 110 IFLAG = MAX0(IERR,IFLAG) RETURN C C ERROR RETURN C 100 IFLAG = -1 RETURN 110 IFLAG = -2 RETURN 120 IFLAG = -3 WK(1) = M RETURN END SUBROUTINE BSLSQ1 (TAU, WGT, NTAU, Z, KZ, M, T, N, K, * A, KA, WK, Q, IERR) C----------------------------------------------------------------------- C C BSLSQ1 PRODUCES THE B-SPLINE COEFFICIENTS A(J,1),...,A(J,N) C OF THE PIECEWISE POLYNOMIAL P(X) OF ORDER K WITH KNOTS T(I) C (I = 1,...,N+K) WHICH MINIMIZES C C SUM (WGT(L)*(P(TAU(L)) - Z(L,J))**2) C L C C FOR J = 1,...,M. C C INPUT ... C C TAU ARRAY OF LENGTH NTAU CONTAINING DATA POINT ABSCISSAE. C WGT ARRAY OF LENGTH NTAU CONTAINING THE WEIGHTS. C NTAU NUMBER OF DATA POINTS TO BE FITTED (NTAU .GE. N). C Z MATRIX CONTAINING M SETS OF ORDINATES TO BE FITTED. C EACH SET OF NTAU ORDINATES IS A COLUMN OF Z. C KZ NUMBER OF ROWS OF Z IN THE CALLING PROGRAM. C IT IS ASSUMED THAT KZ .GE. NTAU. C M NUMBER OF SETS OF ORDINATES TO BE FITTED. C T KNOT SEQUENCE OF LENGTH N+K. C N DIMENSION OF THE PIECEWISE POLYNOMIAL SPACE. C K ORDER OF THE B-SPLINES. C KA NUMBER OF ROWS OF A IN THE CALLING PROGRAM. C IT IS ASSUMED THAT KA .GE. M. C C OUTPUT ... C C A MATRIX CONTAINING THE M SETS OF B-SPLINE COEFFICIENTS C OF THE L2 APPROXIMATIONS. EACH SET OF N COEFFICIENTS C IS A ROW OF A. C C IERR INTEGER REPORTING THE STATUS OF THE RESULTS ... C C 0 THE COEFFICIENT MATRIX IS NONSIGULAR. THE C UNIQUE LEAST SQUARES SOLUTION WAS OBTAINED. C 1 THE COEFFICIENT MATRIX IS SINGULAR. A C LEAST SQUARES SOLUTION WAS OBTAINED. C -1 INPUT ERRORS WERE DETECTED. C C----------------------------------------------------------------------- REAL TAU(NTAU), WGT(NTAU), Z(KZ,M) REAL T(*), A(KA,N), WK(N), Q(K,N) C IF (NTAU .LT. MAX0(2,K)) GO TO 100 IF (TAU(1) .LT. T(K) .OR. TAU(NTAU) .GT. T(N + 1)) GO TO 100 C DO 10 I = 2,NTAU IF (TAU(I - 1) .GT. TAU(I)) GO TO 100 10 CONTINUE C DO 21 J = 1,N DO 20 I = 1,M A(I,J) = 0.0 20 CONTINUE 21 CONTINUE C DO 31 J = 1,N DO 30 I = 1,K Q(I,J) = 0.0 30 CONTINUE 31 CONTINUE C LEFT = K DO 90 L = 1,NTAU C C *** FIND THE INDEX LEFT SUCH THAT C T(LEFT) .LE. TAU(L) .LT. T(LEFT+1) C 40 IF (LEFT .EQ. N) GO TO 50 IF (TAU(L) .LT. T(LEFT+1)) GO TO 50 LEFT = LEFT + 1 GO TO 40 C 50 JJ = 0 CALL BSPVB (T, K, K, JJ, TAU(L), LEFT, WK) C LEFTMK = LEFT - K DO 80 MM = 1,K DW = WK(MM)*WGT(L) J = LEFTMK + MM DO 60 I = 1,M A(I,J) = DW*Z(L,I) + A(I,J) 60 CONTINUE I = 1 DO 70 JJ = MM,K Q(I,J) = WK(JJ)*DW + Q(I,J) I = I + 1 70 CONTINUE 80 CONTINUE 90 CONTINUE C C SOLVE THE NORMAL EQUATIONS C CALL BCHFAC (Q, K, N, WK, IERR) CALL BCHSV1 (Q, K, N, A, KA, M) RETURN C C ERROR RETURN C 100 IERR = -1 RETURN END SUBROUTINE BCHSV1 (W, NB, N, B, KB, M) C----------------------------------------------------------------------- C C BCHSV1 SOLVES M LINEAR SYSTEMS C*X = B (I = 1,...,M), WHERE C I I C EACH B IS A VECTOR STORED IN THE I-TH ROW OF A MATRIX B. C I C ------------------ C C INPUT ... C C N THE ORDER OF THE MATRIX C C NB THE BANDWIDTH OF C C W THE CHOLESKY FACTORIZATION OF THE BANDED SYMMETRIC C POSITIVE DEFINITE MATRIX C OBTAINED BY THE ROUTINE C BCHFAC. C B MATRIX WHOSE ROWS ARE THE VECTORS TO BE SOLVED FOR C IN THE M LINEAR SYSTEMS OF EQUATIONS. C KB THE NUMBER OF ROWS OF B SPECIFIED IN THE CALLING C PROGRAM. IT IS ASSUMED THAT KB .GE. M. C M NUMBER OF LINEAR SYSTEMS TO BE SOLVED. C C OUTPUT ... C C B MATRIX WHOSE ROWS ARE THE SOLUTIONS X OF THE M C LINEAR SYSTEMS OF EQUATIONS. I C C T C NOTE. THE FACTORIZATION C = L*D*L IS USED, WHERE L IS A C UNIT LOWER TRIANGULAR MATRIX AND D A DIAGONAL MATRIX. C C----------------------------------------------------------------------- REAL W(NB,N), B(KB,N) C IF (N .GT. 1) GO TO 20 DO 10 I = 1,M B(I,1) = B(I,1)*W(1,1) 10 CONTINUE RETURN C C FORWARD SUBSTITUTION. SOLVE L*Y = B FOR Y AND STORE Y IN B. C 20 NBM1 = NB - 1 DO 40 K = 1,N JMAX = MIN0(NBM1,N - K) IF (JMAX .LT. 1) GO TO 40 DO 31 J = 1,JMAX JPK = J + K T = W(J + 1,K) DO 30 I = 1,M B(I,JPK) = B(I,JPK) - T*B(I,K) 30 CONTINUE 31 CONTINUE 40 CONTINUE C T -1 C BACKSUBSTITUTION. SOLVE L X = D Y FOR X AND STORE X IN B. C K = N 50 T = W(1,K) DO 60 I = 1,M B(I,K) = T*B(I,K) 60 CONTINUE JMAX = MIN0(NBM1,N - K) IF (JMAX .LT. 1) GO TO 80 DO 71 J = 1,JMAX JPK = J + K T = W(J + 1,K) DO 70 I = 1,M B(I,K) = B(I,K) - T*B(I,JPK) 70 CONTINUE 71 CONTINUE 80 K = K - 1 IF (K .GT. 0) GO TO 50 RETURN END SUBROUTINE BVAL2 (A, KA, TX, NX, KX, TY, NY, KY, X0, Y0, * IDX, IDY, F, WK) C----------------------------------------------------------------------- C C EVALUATION AND PARTIAL DIFFERENTIATION C OF A PIECEWISE POLYNOMIAL C C NX NY C F(X,Y) = SUM SUM A U (X) V (Y) C I=1 J=1 IJ I J C C WHERE U AND V ARE ONE-DIMENSIONAL B-SPLINE BASIS FUNCTIONS. C I J C----------------------------------------------------------------------- C REAL TX(NX + KX), TY(NY + KY), WK(KY + 3*MAX(KX,KY)) C----------------------------- REAL A(KA,NY), TX(*), TY(*), WK(*) C F = 0.0 M = NX + KX IF (X0 .LT. TX(1) .OR. X0 .GT. TX(M)) RETURN M = NY + KY IF (Y0 .LT. TY(1) .OR. Y0 .GT. TY(M)) RETURN C IW = KY + 1 J = INTRVL(Y0, TY, M) IF (J .GT. KY) GO TO 20 C C CASE WHEN J .LE. KY C DO 10 L = 1,J CALL BVAL (TX, A(1,L), NX, KX, X0, IDX, WK(L), WK(IW)) 10 CONTINUE CALL BVAL (TY, WK(1), J, KY, Y0, IDY, F, WK(IW)) RETURN C C CASE WHEN J .GT. KY C 20 L = J - KY DO 30 I = 1,KY L = L + 1 CALL BVAL (TX, A(1,L), NX, KX, X0, IDX, WK(I), WK(IW)) 30 CONTINUE L = J - KY + 1 CALL BVAL (TY(L), WK(1), KY, KY, Y0, IDY, F, WK(IW)) RETURN END SUBROUTINE TRMESH (N,X,Y, IADJ,IEND,IER) INTEGER N, IADJ(*), IEND(N), IER REAL X(N), Y(N) C C*********************************************************** C C ROBERT RENKA C OAK RIDGE NATL. LAB. C (615) 576-5139 C C THIS ROUTINE CREATES A THIESSEN TRIANGULATION OF N C ARBITRARILY SPACED POINTS IN THE PLANE REFERRED TO AS C NODES. THE TRIANGULATION IS OPTIMAL IN THE SENSE THAT IT C IS AS NEARLY EQUIANGULAR AS POSSIBLE. TRMESH IS PART OF C AN INTERPOLATION PACKAGE WHICH ALSO PROVIDES SUBROUTINES C TO REORDER THE NODES, ADD A NEW NODE, DELETE AN ARC, PLOT C THE MESH, AND PRINT THE DATA STRUCTURE. C UNLESS THE NODES ARE ALREADY ORDERED IN SOME REASONABLE C FASHION, THEY SHOULD BE REORDERED BY SUBROUTINE REORDR FOR C INCREASED EFFICIENCY BEFORE CALLING TRMESH. C C INPUT PARAMETERS - N - NUMBER OF NODES IN THE MESH. C N .GE. 3. C C X,Y - N-VECTORS OF COORDINATES. C (X(I),Y(I)) DEFINES NODE I. C C IADJ - VECTOR OF LENGTH .GE. 6*N-9. C C IEND - VECTOR OF LENGTH .GE. N. C C N, X, AND Y ARE NOT ALTERED BY THIS ROUTINE. C C OUTPUT PARAMETERS - IADJ - ADJACENCY LISTS OF NEIGHBORS IN C COUNTERCLOCKWISE ORDER. THE C LIST FOR NODE I+1 FOLLOWS THAT C FOR NODE I WHERE X AND Y DEFINE C THE ORDER. THE VALUE 0 DENOTES C THE BOUNDARY (OR A PSEUDO-NODE C AT INFINITY) AND IS ALWAYS THE C LAST NEIGHBOR OF A BOUNDARY C NODE. IADJ IS UNCHANGED IF IER C .NE. 0. C C IEND - POINTERS TO THE ENDS OF C ADJACENCY LISTS (SETS OF C NEIGHBORS) IN IADJ. THE C NEIGHBORS OF NODE 1 BEGIN IN C IADJ(1). FOR K .GT. 1, THE C NEIGHBORS OF NODE K BEGIN IN C IADJ(IEND(K-1)+1) AND K HAS C IEND(K) - IEND(K-1) NEIGHBORS C INCLUDING (POSSIBLY) THE C BOUNDARY. IADJ(IEND(K)) .EQ. 0 C IFF NODE K IS ON THE BOUNDARY. C IEND IS UNCHANGED IF IER = 1. C IF IER = 2 IEND CONTAINS THE C INDICES OF A SEQUENCE OF N C NODES ORDERED FROM LEFT TO C RIGHT WHERE LEFT AND RIGHT ARE C DEFINED BY ASSUMING NODE 1 IS C TO THE LEFT OF NODE 2. C C IER - ERROR INDICATOR C IER = 0 IF NO ERRORS WERE C ENCOUNTERED. C IER = 1 IF N .LT. 3. C IER = 2 IF N .GE. 3 AND ALL C NODES ARE COLLINEAR. C C MODULES REFERENCED BY TRMESH - SHIFTD, ADNODE, TRFIND, C INTADD, BDYADD, SWPTST, C SWAPD, TINDX C C*********************************************************** C INTEGER NN, K, KM1, NL, NR, IND, INDX, N0, ITEMP, . IERR, KM1D2, KMI, I, KMIN REAL XL, YL, XR, YR, DXR, DYR, XK, YK, DXK, DYK, . CPROD, SPROD C C LOCAL PARAMETERS - C C NN = LOCAL COPY OF N C K = NODE (INDEX) TO BE INSERTED INTO IEND C KM1 = K-1 - (VARIABLE) LENGTH OF IEND C NL,NR = IEND(1), IEND(KM1) -- LEFTMOST AND RIGHTMOST C NODES IN IEND AS VIEWED FROM THE RIGHT OF C 1-2 WHEN IEND CONTAINS THE INITIAL ORDERED C SET OF NODAL INDICES C XL,YL,XR,YR = X AND Y COORDINATES OF NL AND NR C DXR,DYR = XR-XL, YR-YL C XK,YK = X AND Y COORDINATES OF NODE K C DXK,DYK = XK-XL, YK-YL C CPROD = VECTOR CROSS PRODUCT OF NL-NR AND NL-K -- C USED TO DETERMINE THE POSITION OF NODE K C WITH RESPECT TO THE LINE DEFINED BY THE C NODES IN IEND C SPROD = SCALAR PRODUCT USED TO DETERMINE THE C INTERVAL CONTAINING NODE K WHEN K IS ON C THE LINE DEFINED BY THE NODES IN IEND C IND,INDX = INDICES FOR IEND AND IADJ, RESPECTIVELY C N0,ITEMP = TEMPORARY NODES (INDICES) C IERR = DUMMY PARAMETER FOR CALL TO ADNODE C KM1D2,KMI,I = KM1/2, K-I, DO-LOOP INDEX -- USED IN IEND C REORDERING LOOP C KMIN = FIRST NODE INDEX SENT TO ADNODE C NN = N IER = 1 IF (NN .LT. 3) RETURN IER = 0 C C INITIALIZE IEND, NL, NR, AND K C IEND(1) = 1 IEND(2) = 2 XL = X(1) YL = Y(1) XR = X(2) YR = Y(2) K = 2 C C BEGIN LOOP ON NODES 3,4,... C 1 DXR = XR-XL DYR = YR-YL C C NEXT LOOP BEGINS HERE IF NL AND NR ARE UNCHANGED C 2 IF (K .EQ. NN) GO TO 13 KM1 = K K = KM1 + 1 XK = X(K) YK = Y(K) DXK = XK-XL DYK = YK-YL CPROD = DXR*DYK - DXK*DYR IF (CPROD .GT. 0.) GO TO 6 IF (CPROD .LT. 0.) GO TO 8 C C NODE K LIES ON THE LINE CONTAINING NODES 1,2,...,K-1. C SET SPROD TO (NL-NR,NL-K). C SPROD = DXR*DXK + DYR*DYK IF (SPROD .GT. 0.) GO TO 3 C C NODE K IS TO THE LEFT OF NL. INSERT K AS THE FIRST C (LEFTMOST) NODE IN IEND AND SET NL TO K. C CALL SHIFTD(1,KM1,1, IEND ) IEND(1) = K XL = XK YL = YK GO TO 1 C C NODE K IS TO THE RIGHT OF NL. FIND THE LEFTMOST NODE C N0 WHICH LIES TO THE RIGHT OF K. C SET SPROD TO (N0-NL,N0-K). C 3 DO 4 IND = 2,KM1 N0 = IEND(IND) SPROD = (XL-X(N0))*(XK-X(N0)) + . (YL-Y(N0))*(YK-Y(N0)) IF (SPROD .GE. 0.) GO TO 5 4 CONTINUE C C NODE K IS TO THE RIGHT OF NR. INSERT K AS THE LAST C (RIGHTMOST) NODE IN IEND AND SET NR TO K. C IEND(K) = K XR = XK YR = YK GO TO 1 C C NODE K LIES BETWEEN IEND(IND-1) AND IEND(IND). INSERT K C IN IEND. C 5 CALL SHIFTD(IND,KM1,1, IEND ) IEND(IND) = K GO TO 2 C C NODE K IS TO THE LEFT OF NL-NR. REORDER IEND SO THAT NL C IS THE LEFTMOST NODE AS VIEWED FROM K. C 6 KM1D2 = KM1/2 DO 7 I = 1,KM1D2 KMI = K-I ITEMP = IEND(I) IEND(I) = IEND(KMI) IEND(KMI) = ITEMP 7 CONTINUE C C NODE K IS TO THE RIGHT OF NL-NR. CREATE A TRIANGULATION C CONSISTING OF NODES 1,2,...,K. C 8 NL = IEND(1) NR = IEND(KM1) C C CREATE THE ADJACENCY LISTS FOR THE FIRST K-1 NODES. C INSERT NEIGHBORS IN REVERSE ORDER. EACH NODE HAS FOUR C NEIGHBORS EXCEPT NL AND NR WHICH HAVE THREE. C DO 9 IND = 1,KM1 N0 = IEND(IND) INDX = 4*N0 IF (N0 .GE. NL) INDX = INDX-1 IF (N0 .GE. NR) INDX = INDX-1 IADJ(INDX) = 0 INDX = INDX-1 IF (IND .LT. KM1) IADJ(INDX) = IEND(IND+1) IF (IND .LT. KM1) INDX = INDX-1 IADJ(INDX) = K IF (IND .EQ. 1) GO TO 9 IADJ(INDX-1) = IEND(IND-1) 9 CONTINUE C C CREATE THE ADJACENCY LIST FOR NODE K C INDX = 5*KM1 - 1 IADJ(INDX) = 0 DO 10 IND = 1,KM1 INDX = INDX-1 IADJ(INDX) = IEND(IND) 10 CONTINUE C C REPLACE IEND ELEMENTS WITH POINTERS TO IADJ C INDX = 0 DO 11 IND = 1,KM1 INDX = INDX + 4 IF (IND .EQ. NL .OR. IND .EQ. NR) INDX = INDX-1 IEND(IND) = INDX 11 CONTINUE INDX = INDX + K IEND(K) = INDX C C ADD THE REMAINING NODES TO THE TRIANGULATION C IF (K .EQ. NN) RETURN KMIN = K+1 DO 12 K = KMIN,NN CALL ADNODE(K,X,Y, IADJ,IEND, IERR) 12 CONTINUE RETURN C C ALL NODES ARE COLLINEAR C 13 IER = 2 RETURN END SUBROUTINE ADNODE (KK,X,Y, IADJ,IEND, IER) INTEGER KK, IADJ(*), IEND(KK), IER REAL X(KK), Y(KK) LOGICAL SWPTST INTEGER TINDX C C*********************************************************** C C ROBERT RENKA C OAK RIDGE NATL. LAB. C (615) 576-5139 C C THIS ROUTINE ADDS NODE KK TO A TRIANGULATION OF A SET C OF POINTS IN THE PLANE PRODUCING A NEW TRIANGULATION. A C SEQUENCE OF EDGE SWAPS IS THEN APPLIED TO THE MESH, C RESULTING IN AN OPTIMAL TRIANGULATION. ADNODE IS PART C OF AN INTERPOLATION PACKAGE WHICH ALSO PROVIDES ROUTINES C TO INITIALIZE THE DATA STRUCTURE, PLOT THE MESH, AND C DELETE ARCS. C C INPUT PARAMETERS - KK - INDEX OF THE NODE TO BE ADDED C TO THE MESH. KK .GE. 4. C C X,Y - VECTORS OF COORDINATES OF THE C NODES IN THE MESH. (X(I),Y(I)) C DEFINES NODE I FOR I = 1,..,KK. C C IADJ - SET OF ADJACENCY LISTS OF NODES C 1,..,KK-1. C C IEND - POINTERS TO THE ENDS OF C ADJACENCY LISTS IN IADJ FOR C EACH NODE IN THE MESH. C C IADJ AND IEND MAY BE CREATED BY TRMESH. C C KK, X, AND Y ARE NOT ALTERED BY THIS ROUTINE. C C OUTPUT PARAMETERS - IADJ,IEND - UPDATED WITH THE ADDITION C OF NODE KK AS THE LAST C ENTRY. C C IER - ERROR INDICATOR C IER = 0 IF NO ERRORS C WERE ENCOUNTERED. C IER = 1 IF ALL NODES C (INCLUDING KK) ARE C COLLINEAR. C C MODULES REFERENCED BY ADNODE - TRFIND, INTADD, BDYADD, C SHIFTD, TINDX, SWPTST, C SWAPD C C*********************************************************** C INTEGER K, KM1, I1, I2, I3, INDKF, INDKL, NABOR1, . IO1, IO2, IN1, INDK1, IND2F, IND21 REAL XK, YK C C LOCAL PARAMETERS - C C K = LOCAL COPY OF KK C KM1 = K - 1 C I1,I2,I3 = VERTICES OF A TRIANGLE CONTAINING K C INDKF = IADJ INDEX OF THE FIRST NEIGHBOR OF K C INDKL = IADJ INDEX OF THE LAST NEIGHBOR OF K C NABOR1 = FIRST NEIGHBOR OF K BEFORE ANY SWAPS OCCUR C IO1,IO2 = ADJACENT NEIGHBORS OF K DEFINING AN ARC TO C BE TESTED FOR A SWAP C IN1 = VERTEX OPPOSITE K -- FIRST NEIGHBOR OF IO2 C WHICH PRECEDES IO1. IN1,IO1,IO2 ARE IN C COUNTERCLOCKWISE ORDER. C INDK1 = INDEX OF IO1 IN THE ADJACENCY LIST FOR K C IND2F = INDEX OF THE FIRST NEIGHBOR OF IO2 C IND21 = INDEX OF IO1 IN THE ADJACENCY LIST FOR IO2 C XK,YK = X(K), Y(K) C IER = 0 K = KK C C INITIALIZATION C KM1 = K - 1 XK = X(K) YK = Y(K) C C ADD NODE K TO THE MESH C CALL TRFIND(KM1,XK,YK,X,Y,IADJ,IEND, I1,I2,I3) IF (I1 .EQ. 0) GO TO 5 IF (I3 .EQ. 0) CALL BDYADD(K,I1,I2, IADJ,IEND ) IF (I3 .NE. 0) CALL INTADD(K,I1,I2,I3, IADJ,IEND ) C C INITIALIZE VARIABLES FOR OPTIMIZATION OF THE MESH C INDKF = IEND(KM1) + 1 INDKL = IEND(K) NABOR1 = IADJ(INDKF) IO2 = NABOR1 INDK1 = INDKF + 1 IO1 = IADJ(INDK1) C C BEGIN LOOP -- FIND THE VERTEX OPPOSITE K C 1 IND2F = 1 IF (IO2 .NE. 1) IND2F = IEND(IO2-1) + 1 IND21 = TINDX(IO2,IO1,IADJ,IEND) IF (IND2F .EQ. IND21) GO TO 2 IN1 = IADJ(IND21-1) GO TO 3 C C IN1 IS THE LAST NEIGHBOR OF IO2 C 2 IND21 = IEND(IO2) IN1 = IADJ(IND21) IF (IN1 .EQ. 0) GO TO 4 C C SWAP TEST -- IF A SWAP OCCURS, TWO NEW ARCS ARE OPPOSITE K C AND MUST BE TESTED. INDK1 AND INDKF MUST BE C DECREMENTED. C 3 IF ( .NOT. SWPTST(IN1,K,IO1,IO2,X,Y) ) GO TO 4 CALL SWAPD (IN1,K,IO1,IO2, IADJ,IEND) IO1 = IN1 INDK1 = INDK1 - 1 INDKF = INDKF - 1 GO TO 1 C C NO SWAP OCCURRED. RESET IO2 AND IO1, AND TEST FOR C TERMINATION. C 4 IF (IO1 .EQ. NABOR1) RETURN IO2 = IO1 INDK1 = INDK1 + 1 IF (INDK1 .GT. INDKL) INDK1 = INDKF IO1 = IADJ(INDK1) IF (IO1 .NE. 0) GO TO 1 RETURN C C ALL NODES ARE COLLINEAR C 5 IER = 1 RETURN END SUBROUTINE BDYADD (KK,I1,I2, IADJ,IEND ) INTEGER KK, I1, I2, IADJ(*), IEND(KK) C C*********************************************************** C C ROBERT RENKA C OAK RIDGE NATL. LAB. C (615) 576-5139 C C THIS ROUTINE ADDS A BOUNDARY NODE TO A TRIANGULATION C OF A SET OF KK-1 POINTS IN THE PLANE. IADJ AND IEND ARE C UPDATED WITH THE INSERTION OF NODE KK. C C INPUT PARAMETERS - KK - INDEX OF AN EXTERIOR NODE TO BE C ADDED. KK .GE. 4. C C I1 - FIRST (RIGHTMOST AS VIEWED FROM C KK) BOUNDARY NODE IN THE MESH C WHICH IS VISIBLE FROM KK - THE C LINE SEGMENT KK-I1 INTERSECTS C NO ARCS. C C I2 - LAST (LEFTMOST) BOUNDARY NODE C WHICH IS VISIBLE FROM KK. C C IADJ - SET OF ADJACENCY LISTS OF NODES C IN THE MESH. C C IEND - POINTERS TO THE ENDS OF C ADJACENCY LISTS IN IADJ FOR C EACH NODE IN THE MESH. C C IADJ AND IEND MAY BE CREATED BY TRMESH AND MUST CONTAIN C THE VERTICES I1 AND I2. I1 AND I2 MAY BE DETERMINED BY C TRFIND. C C KK, I1, AND I2 ARE NOT ALTERED BY THIS ROUTINE. C C OUTPUT PARAMETERS - IADJ,IEND - UPDATED WITH THE ADDITION C OF NODE KK AS THE LAST C ENTRY. NODE KK WILL BE C CONNECTED TO I1, I2, AND C ALL BOUNDARY NODES BETWEEN C THEM. NO OPTIMIZATION OF C THE MESH IS PERFORMED. C C MODULE REFERENCED BY BDYADD - SHIFTD C C INTRINSIC FUNCTIONS CALLED BY BDYADD - MIN0, MAX0 C C*********************************************************** C INTEGER K, KM1, NRIGHT, NLEFT, NF, NL, N1, N2, I, . IMIN, IMAX, KEND, NEXT, INDX C C LOCAL PARAMETERS - C C K = LOCAL COPY OF KK C KM1 = K - 1 C NRIGHT,NLEFT = LOCAL COPIES OF I1, I2 C NF,NL = INDICES OF IADJ BOUNDING THE PORTION OF THE C ARRAY TO BE SHIFTED C N1 = IADJ INDEX OF THE FIRST NEIGHBOR OF NLEFT C N2 = IADJ INDEX OF THE LAST NEIGHBOR OF NRIGHT C I = DO-LOOP INDEX C IMIN,IMAX = BOUNDS ON DO-LOOP INDEX -- FIRST AND LAST C ELEMENTS OF IEND TO BE INCREMENTED C KEND = POINTER TO THE LAST NEIGHBOR OF K IN IADJ C NEXT = NEXT BOUNDARY NODE TO BE CONNECTED TO KK C INDX = INDEX FOR IADJ C K = KK KM1 = K - 1 NRIGHT = I1 NLEFT = I2 C C INITIALIZE VARIABLES C NL = IEND(KM1) N1 = 1 IF (NLEFT .NE. 1) N1 = IEND(NLEFT-1) + 1 N2 = IEND(NRIGHT) NF = MAX0(N1,N2) C C INSERT K AS A NEIGHBOR OF MAX(NRIGHT,NLEFT) C CALL SHIFTD(NF,NL,2, IADJ ) IADJ(NF+1) = K IMIN = MAX0(NRIGHT,NLEFT) DO 1 I = IMIN,KM1 IEND(I) = IEND(I) + 2 1 CONTINUE C C INITIALIZE KEND AND INSERT K AS A NEIGHBOR OF C MIN(NRIGHT,NLEFT) C KEND = NL + 3 NL = NF - 1 NF = MIN0(N1,N2) CALL SHIFTD(NF,NL,1, IADJ ) IADJ(NF) = K IMAX = IMIN - 1 IMIN = MIN0(NRIGHT,NLEFT) DO 2 I = IMIN,IMAX IEND(I) = IEND(I) + 1 2 CONTINUE C C INSERT NRIGHT AS THE FIRST NEIGHBOR OF K C IADJ(KEND) = NRIGHT C C INITIALIZE INDX FOR LOOP ON BOUNDARY NODES BETWEEN NRIGHT C AND NLEFT C INDX = IEND(NRIGHT) - 2 3 NEXT = IADJ(INDX) IF (NEXT .EQ. NLEFT) GO TO 4 C C CONNECT NEXT AND K C KEND = KEND + 1 IADJ(KEND) = NEXT INDX = IEND(NEXT) IADJ(INDX) = K INDX = INDX - 1 GO TO 3 C C INSERT NLEFT AND 0 AS THE LAST NEIGHBORS OF K C 4 IADJ(KEND+1) = NLEFT KEND = KEND + 2 IADJ(KEND) = 0 IEND(K) = KEND RETURN END SUBROUTINE INTADD (KK,I1,I2,I3, IADJ,IEND ) INTEGER KK, I1, I2, I3, IADJ(*), IEND(KK) C C*********************************************************** C C ROBERT RENKA C OAK RIDGE NATL. LAB. C (615) 576-5139 C C THIS ROUTINE ADDS AN INTERIOR NODE TO A TRIANGULATION C OF A SET OF KK-1 POINTS IN THE PLANE. IADJ AND IEND ARE C UPDATED WITH THE INSERTION OF NODE KK IN THE TRIANGLE C WHOSE VERTICES ARE I1, I2, AND I3. C C INPUT PARAMETERS - KK - INDEX OF NODE TO BE C INSERTED. KK .GE. 4. C C I1,I2,I3 - INDICES OF THE VERTICES OF C A TRIANGLE CONTAINING NODE C KK -- IN COUNTERCLOCKWISE C ORDER. C C IADJ - SET OF ADJACENCY LISTS C OF NODES IN THE MESH. C C IEND - POINTERS TO THE ENDS OF C ADJACENCY LISTS IN IADJ FOR C EACH NODE IN THE MESH. C C IADJ AND IEND MAY BE CREATED BY TRMESH AND MUST CONTAIN C THE VERTICES I1, I2, AND I3. I1,I2,I3 MAY BE DETERMINED C BY TRFIND. C C KK, I1, I2, AND I3 ARE NOT ALTERED BY THIS ROUTINE. C C OUTPUT PARAMETERS - IADJ,IEND - UPDATED WITH THE ADDITION C OF NODE KK AS THE LAST C ENTRY. NODE KK WILL BE C CONNECTED TO NODES I1, I2, C AND I3. NO OPTIMIZATION C OF THE MESH IS PERFORMED. C C MODULE REFERENCED BY INTADD - SHIFTD C C INTRINSIC FUNCTION CALLED BY INTADD - MOD C C*********************************************************** C INTEGER K, KM1, N(3), NFT(3), IP1, IP2, IP3, INDX, NF, . NL, N1, N2, IMIN, IMAX, I, ITEMP C C LOCAL PARAMETERS - C C K = LOCAL COPY OF KK C KM1 = K - 1 C N = VECTOR CONTAINING I1, I2, I3 C NFT = POINTERS TO THE TOPS OF THE 3 SETS OF IADJ C ELEMENTS TO BE SHIFTED DOWNWARD C IP1,IP2,IP3 = PERMUTATION INDICES FOR N AND NFT C INDX = INDEX FOR IADJ AND N C NF,NL = INDICES OF FIRST AND LAST ENTRIES IN IADJ C TO BE SHIFTED DOWN C N1,N2 = FIRST 2 VERTICES OF A NEW TRIANGLE -- C (N1,N2,KK) C IMIN,IMAX = BOUNDS ON DO-LOOP INDEX -- FIRST AND LAST C ELEMENTS OF IEND TO BE INCREMENTED C I = DO-LOOP INDEX C ITEMP = TEMPORARY STORAGE LOCATION C K = KK C C INITIALIZATION C N(1) = I1 N(2) = I2 N(3) = I3 C C SET UP NFT C DO 2 I = 1,3 N1 = N(I) INDX = MOD(I,3) + 1 N2 = N(INDX) INDX = IEND(N1) + 1 C C FIND THE INDEX OF N2 AS A NEIGHBOR OF N1 C 1 INDX = INDX - 1 IF (IADJ(INDX) .NE. N2) GO TO 1 NFT(I) = INDX + 1 2 CONTINUE C C ORDER THE VERTICES BY DECREASING MAGNITUDE. C N(IP(I+1)) PRECEDES N(IP(I)) IN IEND FOR C I = 1,2. C IP1 = 1 IP2 = 2 IP3 = 3 IF ( N(2) .LE. N(1) ) GO TO 3 IP1 = 2 IP2 = 1 3 IF ( N(3) .LE. N(IP1) ) GO TO 4 IP3 = IP1 IP1 = 3 4 IF ( N(IP3) .LE. N(IP2) ) GO TO 5 ITEMP = IP2 IP2 = IP3 IP3 = ITEMP C C ADD NODE K TO THE ADJACENCY LISTS OF EACH VERTEX AND C UPDATE IEND. FOR EACH VERTEX, A SET OF IADJ ELEMENTS C IS SHIFTED DOWNWARD AND K IS INSERTED. SHIFTING STARTS C AT THE END OF THE ARRAY. C 5 KM1 = K - 1 NL = IEND(KM1) NF = NFT(IP1) IF (NF .LE. NL) CALL SHIFTD(NF,NL,3, IADJ ) IADJ(NF+2) = K IMIN = N(IP1) IMAX = KM1 DO 6 I = IMIN,IMAX IEND(I) = IEND(I) + 3 6 CONTINUE C NL = NF - 1 NF = NFT(IP2) CALL SHIFTD(NF,NL,2, IADJ ) IADJ(NF+1) = K IMAX = IMIN - 1 IMIN = N(IP2) DO 7 I = IMIN,IMAX IEND(I) = IEND(I) + 2 7 CONTINUE C NL = NF - 1 NF = NFT(IP3) CALL SHIFTD(NF,NL,1, IADJ ) IADJ(NF) = K IMAX = IMIN - 1 IMIN = N(IP3) DO 8 I = IMIN,IMAX IEND(I) = IEND(I) + 1 8 CONTINUE C C ADD NODE K TO IEND AND ITS NEIGHBORS TO IADJ C INDX = IEND(KM1) IEND(K) = INDX + 3 DO 9 I = 1,3 INDX = INDX + 1 IADJ(INDX) = N(I) 9 CONTINUE RETURN END SUBROUTINE SHIFTD (NFRST,NLAST,KK, IARR ) INTEGER NFRST, NLAST, KK, IARR(*) C C*********************************************************** C C ROBERT RENKA C OAK RIDGE NATL. LAB. C (615) 576-5139 C C THIS ROUTINE SHIFTS A SET OF CONTIGUOUS ELEMENTS OF AN C INTEGER ARRAY KK POSITIONS DOWNWARD (UPWARD IF KK .LT. 0). C THE LOOPS ARE UNROLLED IN ORDER TO INCREASE EFFICIENCY. C C INPUT PARAMETERS - NFRST,NLAST - BOUNDS ON THE PORTION OF C IARR TO BE SHIFTED. ALL C ELEMENTS BETWEEN AND C INCLUDING THE BOUNDS ARE C SHIFTED UNLESS NFRST .GT. C NLAST, IN WHICH CASE NO C SHIFT OCCURS. C C KK - NUMBER OF POSITIONS EACH C ELEMENT IS TO BE SHIFTED. C IF KK .LT. 0 SHIFT UP. C IF KK .GT. 0 SHIFT DOWN. C C IARR - INTEGER ARRAY OF LENGTH C .GE. NLAST + MAX(KK,0). C C NFRST, NLAST, AND KK ARE NOT ALTERED BY THIS ROUTINE. C C OUTPUT PARAMETER - IARR - SHIFTED ARRAY. C C MODULES REFERENCED BY SHIFTD - NONE C C*********************************************************** C INTEGER INC, K, NF, NL, NLP1, NS, NSL, I, IBAK, INDX, . IMAX DATA INC/5/ C C LOCAL PARAMETERS - C C INC = DO-LOOP INCREMENT (UNROLLING FACTOR) -- IF INC IS C CHANGED, STATEMENTS MUST BE ADDED TO OR DELETED C FROM THE DO-LOOPS C K = LOCAL COPY OF KK C NF = LOCAL COPY OF NFRST C NL = LOCAL COPY OF NLAST C NLP1 = NL + 1 C NS = NUMBER OF SHIFTS C NSL = NUMBER OF SHIFTS DONE IN UNROLLED DO-LOOP (MULTIPLE C OF INC) C I = DO-LOOP INDEX AND INDEX FOR IARR C IBAK = INDEX FOR DOWNWARD SHIFT OF IARR C INDX = INDEX FOR IARR C IMAX = BOUND ON DO-LOOP INDEX C K = KK NF = NFRST NL = NLAST IF (NF .GT. NL .OR. K .EQ. 0) RETURN NLP1 = NL + 1 NS = NLP1 - NF NSL = INC*(NS/INC) IF ( K .LT. 0) GO TO 4 C C SHIFT DOWNWARD STARTING FROM THE BOTTOM C IF (NSL .LE. 0) GO TO 2 DO 1 I = 1,NSL,INC IBAK = NLP1 - I INDX = IBAK + K IARR(INDX) = IARR(IBAK) IARR(INDX-1) = IARR(IBAK-1) IARR(INDX-2) = IARR(IBAK-2) IARR(INDX-3) = IARR(IBAK-3) IARR(INDX-4) = IARR(IBAK-4) 1 CONTINUE C C PERFORM THE REMAINING NS-NSL SHIFTS ONE AT A TIME C 2 IBAK = NLP1 - NSL 3 IF (IBAK .LE. NF) RETURN IBAK = IBAK - 1 INDX = IBAK + K IARR(INDX) = IARR(IBAK) GO TO 3 C C SHIFT UPWARD STARTING FROM THE TOP C 4 IF (NSL .LE. 0) GO TO 6 IMAX = NLP1 - INC DO 5 I = NF,IMAX,INC INDX = I + K IARR(INDX) = IARR(I) IARR(INDX+1) = IARR(I+1) IARR(INDX+2) = IARR(I+2) IARR(INDX+3) = IARR(I+3) IARR(INDX+4) = IARR(I+4) 5 CONTINUE C C PERFORM THE REMAINING NS-NSL SHIFTS ONE AT A TIME C 6 I = NSL + NF 7 IF (I .GT. NL) RETURN INDX = I + K IARR(INDX) = IARR(I) I = I + 1 GO TO 7 END SUBROUTINE SWAPD (NIN1,NIN2,NOUT1,NOUT2, IADJ,IEND) INTEGER NIN1, NIN2, NOUT1, NOUT2, IADJ(*), IEND(*) INTEGER TINDX C C*********************************************************** C C ROBERT RENKA C OAK RIDGE NATL. LAB. C (615) 576-5139 C C THIS SUBROUTINE SWAPS THE DIAGONALS IN A CONVEX QUADRI- C LATERAL. C C INPUT PARAMETERS - NIN1,NIN2,NOUT1,NOUT2 - NODAL INDICES C OF A PAIR OF ADJACENT TRIANGLES C WHICH FORM A CONVEX QUADRILAT- C ERAL. NOUT1 AND NOUT2 ARE CON- C NECTED BY AN ARC WHICH IS TO BE C REPLACED BY THE ARC NIN1-NIN2. C (NIN1,NOUT1,NOUT2) MUST BE TRI- C ANGLE VERTICES IN COUNTERCLOCK- C WISE ORDER. C C THE ABOVE PARAMETERS ARE NOT ALTERED BY THIS ROUTINE. C C IADJ,IEND - TRIANGULATION DATA STRUCTURE C (SEE SUBROUTINE TRMESH). C C OUTPUT PARAMETERS - IADJ,IEND - UPDATED WITH THE ARC C REPLACEMENT. C C MODULES REFERENCED BY SWAPD - TINDX, SHIFTD C C*********************************************************** C INTEGER IN(2), IO(2), IP1, IP2, J, K, NF, NL, I, . IMIN, IMAX C C LOCAL PARAMETERS - C C IN = NIN1 AND NIN2 ORDERED BY INCREASING MAGNITUDE C (THE NEIGHBORS OF IN(1) PRECEDE THOSE OF C IN(2) IN IADJ) C IO = NOUT1 AND NOUT2 IN INCREASING ORDER C IP1,IP2 = PERMUTATION OF (1,2) SUCH THAT IO(IP1) C PRECEDES IO(IP2) AS A NEIGHBOR OF IN(1) C J,K = PERMUTATION OF (1,2) USED AS INDICES OF IN C AND IO C NF,NL = IADJ INDICES BOUNDARY A PORTION OF THE ARRAY C TO BE SHIFTED C I = IEND INDEX C IMIN,IMAX = BOUNDS ON THE PORTION OF IEND TO BE INCRE- C MENTED OR DECREMENTED C IN(1) = NIN1 IN(2) = NIN2 IO(1) = NOUT1 IO(2) = NOUT2 IP1 = 1 C C ORDER THE INDICES SO THAT IN(1) .LT. IN(2) AND IO(1) .LT. C IO(2), AND CHOOSE IP1 AND IP2 SUCH THAT (IN(1),IO(IP1), C IO(IP2)) FORMS A TRIANGLE. C IF (IN(1) .LT. IN(2)) GO TO 1 IN(1) = IN(2) IN(2) = NIN1 IP1 = 2 1 IF (IO(1) .LT. IO(2)) GO TO 2 IO(1) = IO(2) IO(2) = NOUT1 IP1 = 3 - IP1 2 IP2 = 3 - IP1 IF (IO(2) .LT. IN(1)) GO TO 8 IF (IN(2) .LT. IO(1)) GO TO 12 C C IN(1) AND IO(1) PRECEDE IN(2) AND IO(2). FOR (J,K) = C (1,2) AND (2,1), DELETE IO(K) AS A NEIGHBOR OF IO(J) C BY SHIFTING A PORTION OF IADJ EITHER UP OR DOWN AND C AND INSERT IN(K) AS A NEIGHBOR OF IN(J). C DO 7 J = 1,2 K = 3 - J IF (IN(J) .GT. IO(J)) GO TO 4 C C THE NEIGHBORS OF IN(J) PRECEDE THOSE OF IO(J) -- SHIFT C DOWN BY 1 C NF = 1 + TINDX(IN(J),IO(IP1),IADJ,IEND) NL = -1 + TINDX(IO(J),IO(K),IADJ,IEND) IF (NF .LE. NL) CALL SHIFTD(NF,NL,1, IADJ ) IADJ(NF) = IN(K) IMIN = IN(J) IMAX = IO(J)-1 DO 3 I = IMIN,IMAX 3 IEND(I) = IEND(I) + 1 GO TO 6 C C THE NEIGHBORS OF IO(J) PRECEDE THOSE OF IN(J) -- SHIFT C UP BY 1 C 4 NF = 1 + TINDX(IO(J),IO(K),IADJ,IEND) NL = -1 + TINDX(IN(J),IO(IP2),IADJ,IEND) IF (NF .LE. NL) CALL SHIFTD(NF,NL,-1, IADJ ) IADJ(NL) = IN(K) IMIN = IO(J) IMAX = IN(J) - 1 DO 5 I = IMIN,IMAX 5 IEND(I) = IEND(I) - 1 C C REVERSE (IP1,IP2) FOR (J,K) = (2,1) C 6 IP1 = IP2 IP2 = 3 - IP1 7 CONTINUE RETURN C C THE VERTICES ARE ORDERED (IO(1),IO(2),IN(1),IN(2)). C DELETE IO(2) BY SHIFTING UP BY 1 C 8 NF = 1 + TINDX(IO(1),IO(2),IADJ,IEND) NL = -1 + TINDX(IO(2),IO(1),IADJ,IEND) IF (NF .LE. NL) CALL SHIFTD(NF,NL,-1, IADJ ) IMIN = IO(1) IMAX = IO(2)-1 DO 9 I = IMIN,IMAX 9 IEND(I) = IEND(I) - 1 C C DELETE IO(1) BY SHIFTING UP BY 2 AND INSERT IN(2) C NF = NL + 2 NL = -1 + TINDX(IN(1),IO(IP2),IADJ,IEND) IF (NF .LE. NL) CALL SHIFTD(NF,NL,-2, IADJ ) IADJ(NL-1) = IN(2) IMIN = IO(2) IMAX = IN(1)-1 DO 10 I = IMIN,IMAX 10 IEND(I) = IEND(I) - 2 C C SHIFT UP BY 1 AND INSERT IN(1) C NF = NL + 1 NL = -1 + TINDX(IN(2),IO(IP1),IADJ,IEND) CALL SHIFTD(NF,NL,-1, IADJ ) IADJ(NL) = IN(1) IMIN = IN(1) IMAX = IN(2)-1 DO 11 I = IMIN,IMAX 11 IEND(I) = IEND(I) - 1 RETURN C C THE VERTICES ARE ORDERED (IN(1),IN(2),IO(1),IO(2)). C DELETE IO(1) BY SHIFTING DOWN BY 1 C 12 NF = 1 + TINDX(IO(1),IO(2),IADJ,IEND) NL = -1 + TINDX(IO(2),IO(1),IADJ,IEND) IF (NF .LE. NL) CALL SHIFTD(NF,NL,1, IADJ ) IMIN = IO(1) IMAX = IO(2) - 1 DO 13 I = IMIN,IMAX 13 IEND(I) = IEND(I) + 1 C C DELETE IO(2) BY SHIFTING DOWN BY 2 AND INSERT IN(1) C NL = NF - 2 NF = 1 + TINDX(IN(2),IO(IP2),IADJ,IEND) IF (NF .LE. NL) CALL SHIFTD(NF,NL,2, IADJ ) IADJ(NF+1) = IN(1) IMIN = IN(2) IMAX = IO(1) - 1 DO 14 I = IMIN,IMAX 14 IEND(I) = IEND(I) + 2 C C SHIFT DOWN BY 1 AND INSERT IN(2) C NL = NF - 1 NF = 1 + TINDX(IN(1),IO(IP1),IADJ,IEND) CALL SHIFTD(NF,NL,1, IADJ ) IADJ(NF) = IN(2) IMIN = IN(1) IMAX = IN(2) - 1 DO 15 I = IMIN,IMAX 15 IEND(I) = IEND(I) + 1 RETURN END LOGICAL FUNCTION SWPTST (IN1,IN2,IO1,IO2,X,Y) INTEGER IN1, IN2, IO1, IO2 REAL X(*), Y(*) C C*********************************************************** C C ROBERT RENKA C OAK RIDGE NATL. LAB. C (615) 576-5139 C C THIS FUNCTION DECIDES WHETHER OR NOT TO REPLACE A C DIAGONAL ARC IN A QUADRILATERAL WITH THE OTHER DIAGONAL. C THE DETERMINATION IS BASED ON THE SIZES OF THE ANGLES C CONTAINED IN THE 2 TRIANGLES DEFINED BY THE DIAGONAL. C THE DIAGONAL IS CHOSEN TO MAXIMIZE THE SMALLEST OF THE C SIX ANGLES OVER THE TWO PAIRS OF TRIANGLES. C C INPUT PARAMETERS - IN1,IN2,IO1,IO2 - NODE INDICES OF THE C FOUR POINTS DEFINING THE C QUADRILATERAL. IO1 AND IO2 C ARE CURRENTLY CONNECTED BY A C DIAGONAL ARC. THIS ARC C SHOULD BE REPLACED BY AN ARC C CONNECTING IN1, IN2 IF THE C DECISION IS MADE TO SWAP. C IN1,IO1,IO2 MUST BE IN C COUNTERCLOCKWISE ORDER. C C X,Y - VECTORS OF NODAL COORDINATES. C (X(I),Y(I)) ARE THE COORD- C INATES OF NODE I FOR I = IN1, C IN2, IO1, OR IO2. C C NONE OF THE INPUT PARAMETERS ARE ALTERED BY THIS ROUTINE. C C OUTPUT PARAMETER - SWPTST - .TRUE. IFF THE ARC CONNECTING C IO1 AND IO2 IS TO BE REPLACED C C MODULES REFERENCED BY SWPTST - NONE C C*********************************************************** C REAL DX11, DX12, DX22, DX21, DY11, DY12, DY22, DY21, . SIN1, SIN2, COS1, COS2, SIN12 C C LOCAL PARAMETERS - C C DX11,DY11 = X,Y COORDINATES OF THE VECTOR IN1-IO1 C DX12,DY12 = X,Y COORDINATES OF THE VECTOR IN1-IO2 C DX22,DY22 = X,Y COORDINATES OF THE VECTOR IN2-IO2 C DX21,DY21 = X,Y COORDINATES OF THE VECTOR IN2-IO1 C SIN1 = CROSS PRODUCT OF THE VECTORS IN1-IO1 AND C IN1-IO2 -- PROPORTIONAL TO SIN(T1) WHERE T1 C IS THE ANGLE AT IN1 FORMED BY THE VECTORS C COS1 = INNER PRODUCT OF THE VECTORS IN1-IO1 AND C IN1-IO2 -- PROPORTIONAL TO COS(T1) C SIN2 = CROSS PRODUCT OF THE VECTORS IN2-IO2 AND C IN2-IO1 -- PROPORTIONAL TO SIN(T2) WHERE T2 C IS THE ANGLE AT IN2 FORMED BY THE VECTORS C COS2 = INNER PRODUCT OF THE VECTORS IN2-IO2 AND C IN2-IO1 -- PROPORTIONAL TO COS(T2) C SIN12 = SIN1*COS2 + COS1*SIN2 -- PROPORTIONAL TO C SIN(T1+T2) C SWPTST = .FALSE. C C COMPUTE THE VECTORS CONTAINING THE ANGLES T1, T2 C DX11 = X(IO1) - X(IN1) DX12 = X(IO2) - X(IN1) DX22 = X(IO2) - X(IN2) DX21 = X(IO1) - X(IN2) C DY11 = Y(IO1) - Y(IN1) DY12 = Y(IO2) - Y(IN1) DY22 = Y(IO2) - Y(IN2) DY21 = Y(IO1) - Y(IN2) C C COMPUTE INNER PRODUCTS C COS1 = DX11*DX12 + DY11*DY12 COS2 = DX22*DX21 + DY22*DY21 C C THE DIAGONALS SHOULD BE SWAPPED IFF (T1+T2) .GT. 180 C DEGREES. THE FOLLOWING TWO TESTS INSURE NUMERICAL C STABILITY. C IF (COS1 .GE. 0. .AND. COS2 .GE. 0.) RETURN IF (COS1 .LT. 0. .AND. COS2 .LT. 0.) GO TO 1 C C COMPUTE VECTOR CROSS PRODUCTS C SIN1 = DX11*DY12 - DX12*DY11 SIN2 = DX22*DY21 - DX21*DY22 SIN12 = SIN1*COS2 + COS1*SIN2 IF (SIN12 .GE. 0.) RETURN 1 SWPTST = .TRUE. RETURN END INTEGER FUNCTION TINDX (NVERTX,NABOR,IADJ,IEND) INTEGER NVERTX, NABOR, IADJ(*), IEND(*) C C*********************************************************** C C ROBERT RENKA C OAK RIDGE NATL. LAB. C (615) 576-5139 C C THIS FUNCTION RETURNS THE INDEX OF NABOR IN THE C ADJACENCY LIST FOR NVERTX. C C INPUT PARAMETERS - NVERTX - NODE WHOSE ADJACENCY LIST IS C TO BE SEARCHED. C C NABOR - NODE WHOSE INDEX IS TO BE C RETURNED. NABOR MUST BE C CONNECTED TO NVERTX. C C IADJ - SET OF ADJACENCY LISTS. C C IEND - POINTERS TO THE ENDS OF C ADJACENCY LISTS IN IADJ. C C INPUT PARAMETERS ARE NOT ALTERED BY THIS FUNCTION. C C OUTPUT PARAMETER - TINDX - IADJ(TINDX) = NABOR. C C MODULES REFERENCED BY TINDX - NONE C C*********************************************************** C INTEGER NB, INDX C C LOCAL PARAMETERS - C C NB = LOCAL COPY OF NABOR C INDX = INDEX FOR IADJ C NB = NABOR C C INITIALIZATION C INDX = IEND(NVERTX) + 1 C C SEARCH THE LIST OF NVERTX NEIGHBORS FOR NB C 1 INDX = INDX - 1 IF (IADJ(INDX) .NE. NB) GO TO 1 C TINDX = INDX RETURN END SUBROUTINE TRFIND (NST,PX,PY,X,Y,IADJ,IEND, I1,I2,I3) INTEGER NST, IADJ(*), IEND(*), I1, I2, I3 REAL PX, PY, X(*), Y(*) C C*********************************************************** C C ROBERT RENKA C OAK RIDGE NATL. LAB. C (615) 576-5139 C C THIS ROUTINE LOCATES A POINT P IN A THIESSEN TRIANGU- C LATION, RETURNING THE VERTEX INDICES OF A TRIANGLE WHICH C CONTAINS P. TRFIND IS PART OF AN INTERPOLATION PACKAGE C WHICH PROVIDES SUBROUTINES FOR CREATING THE MESH. C C INPUT PARAMETERS - NST - INDEX OF NODE AT WHICH TRFIND C BEGINS SEARCH. SEARCH TIME C DEPENDS ON THE PROXIMITY OF C NST TO P. C C PX,PY - X AND Y-COORDINATES OF THE C POINT TO BE LOCATED. C C X,Y - VECTORS OF COORDINATES OF C NODES IN THE MESH. (X(I),Y(I)) C DEFINES NODE I FOR I = 1,...,N C WHERE N .GE. 3. C C IADJ - SET OF ADJACENCY LISTS OF C NODES IN THE MESH. C C IEND - POINTERS TO THE ENDS OF C ADJACENCY LISTS IN IADJ FOR C EACH NODE IN THE MESH. C C IADJ AND IEND MAY BE CREATED BY TRMESH. C C INPUT PARAMETERS ARE NOT ALTERED BY THIS ROUTINE. C C OUTPUT PARAMETERS - I1,I2,I3 - VERTEX INDICES IN COUNTER- C CLOCKWISE ORDER - VERTICES C OF A TRIANGLE CONTAINING P C IF P IS AN INTERIOR NODE. C IF P IS OUTSIDE OF THE C BOUNDARY OF THE MESH, I1 C AND I2 ARE THE FIRST (RIGHT C -MOST) AND LAST (LEFTMOST) C NODES WHICH ARE VISIBLE C FROM P, AND I3 = 0. IF P C AND ALL OF THE NODES LIE ON C A SINGLE LINE THEN I1 = I2 C = I3 = 0. C C MODULES REFERENCED BY TRFIND - NONE C C INTRINSIC FUNCTION CALLED BY TRFIND - MAX0 C C*********************************************************** C INTEGER N0, N1, N2, N3, N4, INDX, IND, NF, . NL, NEXT REAL XP, YP LOGICAL LEFT C C LOCAL PARAMETERS - C C XP,YP = LOCAL VARIABLES CONTAINING PX AND PY C N0,N1,N2 = NODES IN COUNTERCLOCKWISE ORDER DEFINING A C CONE (WITH VERTEX N0) CONTAINING P C N3,N4 = NODES OPPOSITE N1-N2 AND N2-N1, RESPECTIVELY C INDX,IND = INDICES FOR IADJ C NF,NL = FIRST AND LAST NEIGHBORS OF N0 IN IADJ, OR C FIRST (RIGHTMOST) AND LAST (LEFTMOST) NODES C VISIBLE FROM P WHEN P IS OUTSIDE THE C BOUNDARY C NEXT = CANDIDATE FOR I1 OR I2 WHEN P IS OUTSIDE OF C THE BOUNDARY C LEFT = STATEMENT FUNCTION WHICH COMPUTES THE SIGN OF C A CROSS PRODUCT (Z-COMPONENT). LEFT(X1,..., C Y0) = .TRUE. IFF (X0,Y0) IS ON OR TO THE C LEFT OF THE VECTOR FROM (X1,Y1) TO (X2,Y2). C LEFT(X1,Y1,X2,Y2,X0,Y0) = (X2-X1)*(Y0-Y1) .GE. . (X0-X1)*(Y2-Y1) XP = PX YP = PY C C INITIALIZE VARIABLES AND FIND A CONE CONTAINING P C N0 = MAX0(NST,1) 1 INDX = IEND(N0) NL = IADJ(INDX) INDX = 1 IF (N0 .NE. 1) INDX = IEND(N0-1) + 1 NF = IADJ(INDX) N1 = NF IF (NL .NE. 0) GO TO 3 C C N0 IS A BOUNDARY NODE. SET NL TO THE LAST NONZERO C NEIGHBOR OF N0. C IND = IEND(N0) - 1 NL = IADJ(IND) IF ( LEFT(X(N0),Y(N0),X(NF),Y(NF),XP,YP) ) GO TO 2 C C P IS OUTSIDE THE BOUNDARY C NL = N0 GO TO 16 2 IF ( LEFT(X(NL),Y(NL),X(N0),Y(N0),XP,YP) ) GO TO 4 C C P IS OUTSIDE THE BOUNDARY AND N0 IS THE RIGHTMOST C VISIBLE BOUNDARY NODE C I1 = N0 GO TO 18 C C N0 IS AN INTERIOR NODE. FIND N1. C 3 IF ( LEFT(X(N0),Y(N0),X(N1),Y(N1),XP,YP) ) GO TO 4 INDX = INDX + 1 N1 = IADJ(INDX) IF (N1 .EQ. NL) GO TO 7 GO TO 3 C C P IS TO THE LEFT OF ARC N0-N1. INITIALIZE N2 TO THE NEXT C NEIGHBOR OF N0. C 4 INDX = INDX + 1 N2 = IADJ(INDX) IF ( .NOT. LEFT(X(N0),Y(N0),X(N2),Y(N2),XP,YP) ) . GO TO 8 N1 = N2 IF (N1 .NE. NL) GO TO 4 IF ( .NOT. LEFT(X(N0),Y(N0),X(NF),Y(NF),XP,YP) ) . GO TO 7 IF (XP .EQ. X(N0) .AND. YP .EQ. Y(N0)) GO TO 6 C C P IS LEFT OF OR ON ARCS N0-NB FOR ALL NEIGHBORS NB C OF N0. C ALL POINTS ARE COLLINEAR IFF P IS LEFT OF NB-N0 FOR C ALL NEIGHBORS NB OF N0. SEARCH THE NEIGHBORS OF N0 C IN REVERSE ORDER. NOTE -- N1 = NL AND INDX POINTS TO C NL. C 5 IF ( .NOT. LEFT(X(N1),Y(N1),X(N0),Y(N0),XP,YP) ) . GO TO 6 IF (N1 .EQ. NF) GO TO 20 INDX = INDX - 1 N1 = IADJ(INDX) GO TO 5 C C P IS TO THE RIGHT OF N1-N0, OR P=N0. SET N0 TO N1 AND C START OVER. C 6 N0 = N1 GO TO 1 C C P IS BETWEEN ARCS N0-N1 AND N0-NF C 7 N2 = NF C C P IS CONTAINED IN A CONE DEFINED BY LINE SEGMENTS N0-N1 C AND N0-N2 WHERE N1 IS ADJACENT TO N2 C 8 N3 = N0 9 IF ( LEFT(X(N1),Y(N1),X(N2),Y(N2),XP,YP) ) GO TO 13 C C SET N4 TO THE FIRST NEIGHBOR OF N2 FOLLOWING N1 C INDX = IEND(N2) IF (IADJ(INDX) .NE. N1) GO TO 10 C C N1 IS THE LAST NEIGHBOR OF N2. C SET N4 TO THE FIRST NEIGHBOR. C INDX = 1 IF (N2 .NE. 1) INDX = IEND(N2-1) + 1 N4 = IADJ(INDX) GO TO 11 C C N1 IS NOT THE LAST NEIGHBOR OF N2 C 10 INDX = INDX-1 IF (IADJ(INDX) .NE. N1) GO TO 10 N4 = IADJ(INDX+1) IF (N4 .NE. 0) GO TO 11 C C P IS OUTSIDE THE BOUNDARY C NF = N2 NL = N1 GO TO 16 C C DEFINE A NEW ARC N1-N2 WHICH INTERSECTS THE LINE C SEGMENT N0-P C 11 IF ( LEFT(X(N0),Y(N0),X(N4),Y(N4),XP,YP) ) GO TO 12 N3 = N2 N2 = N4 GO TO 9 12 N3 = N1 N1 = N4 GO TO 9 C C P IS IN THE TRIANGLE (N1,N2,N3) AND NOT ON N2-N3. IF C N3-N1 OR N1-N2 IS A BOUNDARY ARC CONTAINING P, TREAT P C AS EXTERIOR. C 13 INDX = IEND(N1) IF (IADJ(INDX) .NE. 0) GO TO 15 C C N1 IS A BOUNDARY NODE. N3-N1 IS A BOUNDARY ARC IFF N3 C IS THE LAST NONZERO NEIGHBOR OF N1. C IF (N3 .NE. IADJ(INDX-1)) GO TO 14 C C N3-N1 IS A BOUNDARY ARC C IF ( .NOT. LEFT(X(N1),Y(N1),X(N3),Y(N3),XP,YP) ) . GO TO 14 C C P LIES ON N1-N3 C I1 = N1 I2 = N3 I3 = 0 RETURN C C N3-N1 IS NOT A BOUNDARY ARC CONTAINING P. N1-N2 IS A C BOUNDARY ARC IFF N2 IS THE FIRST NEIGHBOR OF N1. C 14 INDX = 1 IF (N1 .NE. 1) INDX = IEND(N1-1) + 1 IF (N2 .NE. IADJ(INDX)) GO TO 15 C C N1-N2 IS A BOUNDARY ARC C IF ( .NOT. LEFT(X(N2),Y(N2),X(N1),Y(N1),XP,YP) ) . GO TO 15 C C P LIES ON N1-N2 C I1 = N2 I2 = N1 I3 = 0 RETURN C C P DOES NOT LIE ON A BOUNDARY ARC. C 15 I1 = N1 I2 = N2 I3 = N3 RETURN C C NF AND NL ARE ADJACENT BOUNDARY NODES WHICH ARE VISIBLE C FROM P. FIND THE FIRST VISIBLE BOUNDARY NODE. C SET NEXT TO THE FIRST NEIGHBOR OF NF. C 16 INDX = 1 IF (NF .NE. 1) INDX = IEND(NF-1) + 1 NEXT = IADJ(INDX) IF ( LEFT(X(NF),Y(NF),X(NEXT),Y(NEXT),XP,YP) ) . GO TO 17 NF = NEXT GO TO 16 C C NF IS THE FIRST (RIGHTMOST) VISIBLE BOUNDARY NODE C 17 I1 = NF C C FIND THE LAST VISIBLE BOUNDARY NODE. NL IS THE FIRST C CANDIDATE FOR I2. C SET NEXT TO THE LAST NEIGHBOR OF NL. C 18 INDX = IEND(NL) - 1 NEXT = IADJ(INDX) IF ( LEFT(X(NEXT),Y(NEXT),X(NL),Y(NL),XP,YP) ) . GO TO 19 NL = NEXT GO TO 18 C C NL IS THE LAST (LEFTMOST) VISIBLE BOUNDARY NODE C 19 I2 = NL I3 = 0 RETURN C C ALL POINTS ARE COLLINEAR C 20 I1 = 0 I2 = 0 I3 = 0 RETURN END SUBROUTINE GRADG (N, X, Y, Z, IADJ, IEND, ZXZY, IERR) C----------------------------------------------------------------------- C DERIVATIVE ESTIMATION C----------------------------------------------------------------------- REAL X(N), Y(N), Z(N), ZXZY(2,N) INTEGER IADJ(*), IEND(N) C IF (N .LT. 3) GO TO 20 C EPS = 0.0 MITER = 5 DO 10 J = 1,N ZXZY(1,J) = 0.0 ZXZY(2,J) = 0.0 10 CONTINUE CALL GRADG1 (N, X, Y, Z, IADJ, IEND, EPS, MITER, ZXZY, IERR) IERR = 0 RETURN C C ERROR RETURN C 20 IERR = 1 RETURN END SUBROUTINE GRADG1 (N,X,Y,Z,IADJ,IEND,EPS, NIT, . ZXZY, IER) INTEGER N, IADJ(*), IEND(N), NIT, IER REAL X(N), Y(N), Z(N), EPS, ZXZY(2,N) C C*********************************************************** C C ROBERT RENKA C OAK RIDGE NATL. LAB. C (615) 576-5139 C C GIVEN A TRIANGULATION OF N NODES IN THE PLANE WITH C ASSOCIATED DATA VALUES, THIS ROUTINE USES A GLOBAL METHOD C TO COMPUTE ESTIMATED GRADIENTS AT THE NODES. THE METHOD C CONSISTS OF MINIMIZING A QUADRATIC FUNCTIONAL Q(G) OVER C THE N-VECTOR G OF GRADIENTS WHERE Q APPROXIMATES THE LIN- C EARIZED CURVATURE OF AN INTERPOLANT F OVER THE TRIANGULA- C TION. THE RESTRICTION OF F TO AN ARC OF THE TRIANGULATION C IS TAKEN TO BE THE HERMITE CUBIC INTERPOLANT OF THE DATA C VALUES AND TANGENTIAL GRADIENT COMPONENTS AT THE END- C POINTS OF THE ARC, AND Q IS THE SUM OF THE LINEARIZED C CURVATURES OF F ALONG THE ARCS -- THE INTEGRALS OVER THE C ARCS OF D2F(T)**2 WHERE D2F(T) IS THE SECOND DERIVATIVE C OF F WITH RESPECT TO DISTANCE T ALONG THE ARC. THIS MIN- C IMIZATION PROBLEM CORRESPONDS TO AN ORDER 2N SYMMETRIC C POSITIVE-DEFINITE SPARSE LINEAR SYSTEM WHICH IS SOLVED FOR C THE X AND Y PARTIAL DERIVATIVES BY THE BLOCK GAUSS-SEIDEL C METHOD WITH 2 BY 2 BLOCKS. C AN ALTERNATIVE METHOD, SUBROUTINE GRADL, COMPUTES A C LOCAL APPROXIMATION TO THE PARTIALS AT A SINGLE NODE AND C MAY BE MORE ACCURATE, DEPENDING ON THE DATA VALUES AND C DISTRIBUTION OF NODES (NEITHER METHOD EMERGED AS SUPERIOR C IN TESTS FOR ACCURACY). HOWEVER, IN TESTS RUN ON AN IBM C 370, GRADG1 WAS FOUND TO BE ABOUT 3.6 TIMES AS FAST FOR C NIT = 4. C C INPUT PARAMETERS - N - NUMBER OF NODES. N .GE. 3. C C X,Y - CARTESIAN COORDINATES OF THE NODES. C C Z - DATA VALUES AT THE NODES. Z(I) IS C ASSOCIATED WITH (X(I),Y(I)). C C IADJ,IEND - DATA STRUCTURE DEFINING THE TRIAN- C GULATION. SEE SUBROUTINE TRMESH. C C EPS - NONNEGATIVE CONVERGENCE CRITERION. C THE METHOD IS TERMINATED WHEN THE C MAXIMUM CHANGE IN A GRADIENT COMPO- C NENT BETWEEN ITERATIONS IS AT MOST C EPS. EPS = 1.E-2 IS SUFFICIENT FOR C EFFECTIVE CONVERGENCE. C C THE ABOVE PARAMETERS ARE NOT ALTERED BY THIS ROUTINE. C C NIT - MAXIMUM NUMBER OF GAUSS-SEIDEL C ITERATIONS TO BE APPLIED. THIS C MAXIMUM WILL LIKELY BE ACHIEVED IF C EPS IS SMALLER THAN THE MACHINE C PRECISION. OPTIMAL EFFICIENCY WAS C ACHIEVED IN TESTING WITH EPS = 0 C AND NIT = 3 OR 4. C C ZXZY - 2 BY N ARRAY WHOSE COLUMNS CONTAIN C INITIAL ESTIMATES OF THE PARTIAL C DERIVATIVES (ZERO VECTORS ARE C SUFFICIENT). C C OUTPUT PARAMETERS - NIT - NUMBER OF GAUSS-SEIDEL ITERA- C TIONS EMPLOYED. C C ZXZY - ESTIMATED X AND Y PARTIAL DERIV- C ATIVES AT THE NODES WITH X PAR- C TIALS IN THE FIRST ROW. ZXZY IS C NOT CHANGED IF IER = 2. C C IER - ERROR INDICATOR C IER = 0 IF THE CONVERGENCE CRI- C TERION WAS ACHIEVED. C IER = 1 IF CONVERGENCE WAS NOT C ACHIEVED WITHIN NIT C ITERATIONS. C IER = 2 IF N OR EPS IS OUT OF C RANGE OR NIT .LT. 0 ON C INPUT. C C MODULES REFERENCED BY GRADG1 - NONE C C INTRINSIC FUNCTIONS CALLED BY GRADG1 - SQRT, AMAX1, ABS C C*********************************************************** C INTEGER NN, MAXIT, ITER, K, INDF, INDL, INDX, NB REAL TOL, DGMAX, XK, YK, ZK, ZXK, ZYK, A11, A12, . A22, R1, R2, DELX, DELY, DELXS, DELYS, DSQ, . DCUB, T, DZX, DZY C C LOCAL PARAMETERS - C C NN = LOCAL COPY OF N C MAXIT = INPUT VALUE OF NIT C ITER = NUMBER OF ITERATIONS USED C K = DO-LOOP AND NODE INDEX C INDF,INDL = IADJ INDICES OF THE FIRST AND LAST NEIGHBORS C OF K C INDX = IADJ INDEX IN THE RANGE INDF,...,INDL C NB = NEIGHBOR OF K C TOL = LOCAL COPY OF EPS C DGMAX = MAXIMUM CHANGE IN A GRADIENT COMPONENT BE- C TWEEN ITERATIONS C XK,YK,ZK = X(K), Y(K), Z(K) C ZXK,ZYK = INITIAL VALUES OF ZXZY(1,K) AND ZXZY(2,K) C A11,A12,A22 = MATRIX COMPONENTS OF THE 2 BY 2 BLOCK A*DG C = R WHERE A IS SYMMETRIC, DG = (DZX,DZY) C IS THE CHANGE IN THE GRADIENT AT K, AND R C IS THE RESIDUAL C R1,R2 = COMPONENTS OF THE RESIDUAL -- DERIVATIVES OF C Q WITH RESPECT TO THE COMPONENTS OF THE C GRADIENT AT NODE K C DELX,DELY = COMPONENTS OF THE ARC NB-K C DELXS,DELYS = DELX**2, DELY**2 C DSQ = SQUARE OF THE DISTANCE D BETWEEN K AND NB C DCUB = D**3 C T = FACTOR OF R1 AND R2 C DZX,DZY = SOLUTION OF THE 2 BY 2 SYSTEM -- CHANGE IN C DERIVATIVES AT K FROM THE PREVIOUS ITERATE C NN = N TOL = EPS MAXIT = NIT C C ERROR CHECKS AND INITIALIZATION C IF (NN .LT. 3 .OR. TOL .LT. 0. .OR. MAXIT .LT. 0) . GO TO 5 ITER = 0 C C TOP OF ITERATION LOOP C 1 IF (ITER .EQ. MAXIT) GO TO 4 DGMAX = 0. INDL = 0 DO 3 K = 1,NN XK = X(K) YK = Y(K) ZK = Z(K) ZXK = ZXZY(1,K) ZYK = ZXZY(2,K) C C INITIALIZE COMPONENTS OF THE 2 BY 2 SYSTEM C A11 = 0. A12 = 0. A22 = 0. R1 = 0. R2 = 0. C C LOOP ON NEIGHBORS NB OF K C INDF = INDL + 1 INDL = IEND(K) DO 2 INDX = INDF,INDL NB = IADJ(INDX) IF (NB .EQ. 0) GO TO 2 C C COMPUTE THE COMPONENTS OF ARC NB-K C DELX = X(NB) - XK DELY = Y(NB) - YK DELXS = DELX*DELX DELYS = DELY*DELY DSQ = DELXS + DELYS DCUB = DSQ*SQRT(DSQ) C C UPDATE THE SYSTEM COMPONENTS FOR NODE NB C A11 = A11 + DELXS/DCUB A12 = A12 + DELX*DELY/DCUB A22 = A22 + DELYS/DCUB T = ( 1.5*(Z(NB)-ZK) - ((ZXZY(1,NB)/2.+ZXK)*DELX + . (ZXZY(2,NB)/2.+ZYK)*DELY) )/DCUB R1 = R1 + T*DELX R2 = R2 + T*DELY 2 CONTINUE C C SOLVE THE 2 BY 2 SYSTEM AND UPDATE DGMAX C DZY = (A11*R2 - A12*R1)/(A11*A22 - A12*A12) DZX = (R1 - A12*DZY)/A11 DGMAX = AMAX1(DGMAX,ABS(DZX),ABS(DZY)) C C UPDATE THE PARTIALS AT NODE K C ZXZY(1,K) = ZXK + DZX 3 ZXZY(2,K) = ZYK + DZY C C INCREMENT ITER AND TEST FOR CONVERGENCE C ITER = ITER + 1 IF (DGMAX .GT. TOL) GO TO 1 C C METHOD CONVERGED C NIT = ITER IER = 0 RETURN C C METHOD FAILED TO CONVERGE WITHIN NIT ITERATIONS C 4 IER = 1 RETURN C C PARAMETER OUT OF RANGE C 5 NIT = 0 IER = 2 RETURN END SUBROUTINE GRADL (N, X, Y, Z, IADJ, IEND, ZXZY, IERR) C----------------------------------------------------------------------- C DERIVATIVE ESTIMATION C----------------------------------------------------------------------- REAL X(N), Y(N), Z(N), ZXZY(2,N) INTEGER IADJ(*), IEND(N) C IF (N .LT. 3) GO TO 20 C DO 10 J = 1,N CALL GRADL1 (N, J, X, Y, Z, IADJ, IEND, ZXZY(1,J), * ZXZY(2,J), IERR) IF (IERR .LT. 0) GO TO 30 10 CONTINUE IERR = 0 RETURN C C ERROR RETURN C 20 IERR = 1 RETURN C 30 IERR = 2 RETURN END SUBROUTINE GRADL1 (N,K,X,Y,Z,IADJ,IEND, DX,DY,IER) INTEGER N, K, IADJ(*), IEND(N), IER REAL X(N), Y(N), Z(N), DX, DY C C*********************************************************** C C ROBERT RENKA C OAK RIDGE NATL. LAB. C (615) 576-5139 C C GIVEN A THIESSEN TRIANGULATION OF N POINTS IN THE PLANE C WITH ASSOCIATED DATA VALUES Z, THIS SUBROUTINE ESTIMATES C X AND Y PARTIAL DERIVATIVES AT NODE K. THE DERIVATIVES C ARE TAKEN TO BE THE PARTIALS AT K OF A QUADRATIC FUNCTION C WHICH INTERPOLATES Z(K) AND FITS THE DATA VALUES AT A SET C OF NEARBY NODES IN A WEIGHTED LEAST SQUARES SENSE. A MAR- C QUARDT STABILIZATION FACTOR IS USED IF NECESSARY TO ENSURE C A WELL-CONDITIONED SYSTEM AND A LINEAR FITTING FUNCTION IS C USED IF N .LT. 6. THUS, A UNIQUE SOLUTION EXISTS UNLESS C THE NODES ARE COLLINEAR. C AN ALTERNATIVE ROUTINE, GRADG, EMPLOYS A GLOBAL METHOD C TO COMPUTE THE PARTIAL DERIVATIVES AT ALL OF THE NODES AT C ONCE. THAT METHOD IS MORE EFFICIENT (WHEN ALL PARTIALS C ARE NEEDED) AND MAY BE MORE ACCURATE, DEPENDING ON THE C DATA. C C INPUT PARAMETERS - N - NUMBER OF NODES IN THE TRIANGULA- C TION. N .GE. 3. C C K - NODE AT WHICH DERIVATIVES ARE C SOUGHT. 1 .LE. K .LE. N. C C X,Y - N-VECTORS CONTAINING THE CARTESIAN C COORDINATES OF THE NODES. C C Z - N-VECTOR CONTAINING THE DATA VALUES C ASSOCIATED WITH THE NODES. C C IADJ - SET OF ADJACENCY LISTS. C C IEND - POINTERS TO THE ENDS OF ADJACENCY C LISTS FOR EACH NODE. C C IADJ AND IEND MAY BE CREATED BY SUBROUTINE TRMESH. C C INPUT PARAMETERS ARE NOT ALTERED BY THIS ROUTINE. C C OUTPUT PARAMETERS - DX,DY - ESTIMATED PARTIAL DERIVATIVES C AT NODE K UNLESS IER .LT. 0. C C IER - ERROR INDICATOR C IER .GT. 0 IF NO ERRORS WERE C ENCOUNTERED. IER C CONTAINS THE NUMBER C OF NODES (INCLUDING C K) USED IN THE FIT. C IER = 3, 4, OR 5 IM- C PLIES A LINEAR FIT. C IER = -1 IF N OR K IS OUT OF C RANGE. C IER = -2 IF ALL NODES ARE C COLLINEAR. C C MODULES REFERENCED BY GRADL1 - GETNP, SETRM, SROTG, SROT C C INTRINSIC FUNCTIONS CALLED BY GRADL1 - MIN0, FLOAT, SQRT, C AMIN1, ABS C C*********************************************************** C INTEGER NN, KK, LMN, LMX, LMIN, LMAX, LM1, LNP, . NPTS(30), IERR, NP, I, J, IM1, JP1, IP1, L REAL SUM, DS, R, RS, RTOL, AVSQ, AV, XK, YK, ZK, . A(6,6), C, S, DMIN, DTOL, SF DATA LMN/10/ DATA LMX/30/, RTOL/1.E-5/, DTOL/.01/, SF/1./ C C LOCAL PARAMETERS - C C NN,KK = LOCAL COPIES OF N AND K C LMN,LMX = MINIMUM AND MAXIMUM VALUES OF LNP FOR N C SUFFICIENTLY LARGE. IN MOST CASES LMN-1 C NODES ARE USED IN THE FIT. 4 .LE. LMN .LE. C LMX. C LMIN,LMAX = MIN(LMN,N), MIN(LMX,N) C LM1 = LMIN-1 OR LNP-1 C LNP = LENGTH OF NPTS C NPTS = ARRAY CONTAINING THE INDICES OF A SEQUENCE OF C NODES ORDERED BY DISTANCE FROM K. NPTS(1)=K C AND THE FIRST LNP-1 ELEMENTS OF NPTS ARE C USED IN THE LEAST SQUARES FIT. UNLESS LNP C EXCEEDS LMAX, NPTS(LNP) DETERMINES R. C IERR = ERROR FLAG FOR CALLS TO GETNP (NOT CHECKED) C NP = ELEMENT OF NPTS TO BE ADDED TO THE SYSTEM C I,J = DO-LOOP INDICES C IM1,JP1 = I-1, J+1 C IP1 = I+1 C L = NUMBER OF COLUMNS OF A**T TO WHICH A ROTATION C IS APPLIED C SUM = SUM OF SQUARED EUCLIDEAN DISTANCES BETWEEN C NODE K AND THE NODES USED IN THE LEAST C SQUARES FIT C DS = SQUARED DISTANCE BETWEEN NODE K AND AN ELE- C MENT OF NPTS C R = DISTANCE BETWEEN NODE K AND NPTS(LNP) OR SOME C POINT FURTHER FROM K THAN NPTS(LMAX) IF C NPTS(LMAX) IS USED IN THE FIT. R IS A C RADIUS OF INFLUENCE WHICH ENTERS INTO THE C WEIGHTS (SEE SUBROUTINE SETRM). C RS = R*R C RTOL = TOLERANCE FOR DETERMINING R. IF THE RELATIVE C CHANGE IN DS BETWEEN TWO ELEMENTS OF NPTS IS C NOT GREATER THAN RTOL THEY ARE TREATED AS C BEING THE SAME DISTANCE FROM NODE K C AVSQ = AV*AV C AV = ROOT-MEAN-SQUARE DISTANCE BETWEEN K AND THE C NODES (OTHER THAN K) IN THE LEAST SQUARES C FIT. THE FIRST 3 COLUMNS OF THE SYSTEM ARE C SCALED BY 1/AVSQ, THE NEXT 2 BY 1/AV. C XK,YK,ZK = COORDINATES AND DATA VALUE ASSOCIATED WITH K C A = TRANSPOSE OF THE AUGMENTED REGRESSION MATRIX C C,S = COMPONENTS OF THE PLANE ROTATION DETERMINED C BY SUBROUTINE SROTG C DMIN = MINIMUM OF THE MAGNITUDES OF THE DIAGONAL C ELEMENTS OF THE REGRESSION MATRIX AFTER C ZEROS ARE INTRODUCED BELOW THE DIAGONAL C DTOL = TOLERANCE FOR DETECTING AN ILL-CONDITIONED C SYSTEM. THE SYSTEM IS ACCEPTED WHEN DMIN C .GE. DTOL C SF = MARQUARDT STABILIZATION FACTOR USED TO DAMP C OUT THE FIRST 3 SOLUTION COMPONENTS (SECOND C PARTIALS OF THE QUADRATIC) WHEN THE SYSTEM C IS ILL-CONDITIONED. AS SF INCREASES, THE C FITTING FUNCTION APPROACHES A LINEAR C NN = N KK = K C C CHECK FOR ERRORS AND INITIALIZE LMIN, LMAX C IF (NN .LT. 3 .OR. KK .LT. 1 .OR. KK .GT. NN) . GO TO 16 LMIN = MIN0(LMN,NN) LMAX = MIN0(LMX,NN) C C COMPUTE NPTS, LNP, AVSQ, AV, AND R. C SET NPTS TO THE CLOSEST LMIN-1 NODES TO K. C SUM = 0. NPTS(1) = KK LM1 = LMIN - 1 DO 1 LNP = 2,LM1 CALL GETNP (X,Y,IADJ,IEND,LNP, NPTS, DS,IERR) 1 SUM = SUM + DS C C ADD ADDITIONAL NODES TO NPTS UNTIL THE RELATIVE INCREASE C IN DS IS AT LEAST RTOL. C DO 2 LNP = LMIN,LMAX CALL GETNP (X,Y,IADJ,IEND,LNP, NPTS, RS,IERR) IF ((RS-DS)/DS .LE. RTOL) GO TO 2 IF (LNP .GT. 6) GO TO 3 2 SUM = SUM + RS C C USE ALL LMAX NODES IN THE LEAST SQUARES FIT. RS IS C ARBITRARILY INCREASED BY 10 PER CENT. C RS = 1.1*RS LNP = LMAX + 1 C C THERE ARE LNP-2 EQUATIONS CORRESPONDING TO NODES NPTS(2), C ...,NPTS(LNP-1). C 3 AVSQ = SUM/FLOAT(LNP-2) AV = SQRT(AVSQ) R = SQRT(RS) XK = X(KK) YK = Y(KK) ZK = Z(KK) IF (LNP .LT. 7) GO TO 12 C C SET UP THE FIRST 5 EQUATIONS OF THE AUGMENTED REGRESSION C MATRIX (TRANSPOSED) AS THE COLUMNS OF A, AND ZERO OUT C THE LOWER TRIANGLE (UPPER TRIANGLE OF A) WITH GIVENS C ROTATIONS C DO 5 I = 1,5 NP = NPTS(I+1) CALL SETRM (XK,YK,ZK,X(NP),Y(NP),Z(NP),AV,AVSQ, . R, A(1,I)) IF (I .EQ. 1) GO TO 5 IM1 = I - 1 DO 4 J = 1,IM1 JP1 = J + 1 L = 6 - J CALL SROTG (A(J,J),A(J,I),C,S) 4 CALL SROT (L,A(JP1,J),1,A(JP1,I),1,C,S) 5 CONTINUE C C ADD THE ADDITIONAL EQUATIONS TO THE SYSTEM USING C THE LAST COLUMN OF A -- I .LE. LNP. C I = 7 6 IF (I .EQ. LNP) GO TO 8 NP = NPTS(I) CALL SETRM (XK,YK,ZK,X(NP),Y(NP),Z(NP),AV,AVSQ, . R, A(1,6)) DO 7 J = 1,5 JP1 = J + 1 L = 6 - J CALL SROTG (A(J,J),A(J,6),C,S) 7 CALL SROT (L,A(JP1,J),1,A(JP1,6),1,C,S) I = I + 1 GO TO 6 C C TEST THE SYSTEM FOR ILL-CONDITIONING C 8 DMIN = AMIN1( ABS(A(1,1)),ABS(A(2,2)),ABS(A(3,3)), . ABS(A(4,4)),ABS(A(5,5)) ) IF (DMIN .GE. DTOL) GO TO 15 IF (LNP .GT. LMAX) GO TO 9 C C ADD ANOTHER NODE TO THE SYSTEM AND INCREASE R -- C I .EQ. LNP C LNP = LNP + 1 IF (LNP .LE. LMAX) CALL GETNP (X,Y,IADJ,IEND,LNP, . NPTS, RS,IERR) R = SQRT(1.1*RS) GO TO 6 C C STABILIZE THE SYSTEM BY DAMPING SECOND PARTIALS --ADD C MULTIPLES OF THE FIRST THREE UNIT VECTORS TO THE FIRST C THREE EQUATIONS. C 9 DO 11 I = 1,3 A(I,6) = SF IP1 = I + 1 DO 10 J = IP1,6 10 A(J,6) = 0. DO 11 J = I,5 JP1 = J + 1 L = 6 - J CALL SROTG (A(J,J),A(J,6),C,S) 11 CALL SROT (L,A(JP1,J),1,A(JP1,6),1,C,S) GO TO 14 C C 4 .LE. LNP .LE. 6 (2, 3, OR 4 EQUATIONS) -- FIT A PLANE TO C THE DATA USING THE LAST 3 COLUMNS OF A. C 12 NP = NPTS(2) CALL SETRM (XK,YK,ZK,X(NP),Y(NP),Z(NP),AV,AVSQ, . R, A(1,4)) NP = NPTS(3) CALL SETRM (XK,YK,ZK,X(NP),Y(NP),Z(NP),AV,AVSQ, . R, A(1,5)) CALL SROTG (A(4,4),A(4,5),C,S) CALL SROT (2,A(5,4),1,A(5,5),1,C,S) IF (LNP .EQ. 4) GO TO 14 C LM1 = LNP - 1 DO 13 I = 4,LM1 NP = NPTS(I) CALL SETRM (XK,YK,ZK,X(NP),Y(NP),Z(NP),AV,AVSQ, . R, A(1,6)) CALL SROTG (A(4,4),A(4,6),C,S) CALL SROT (2,A(5,4),1,A(5,6),1,C,S) CALL SROTG (A(5,5),A(5,6),C,S) 13 CALL SROT (1,A(6,5),1,A(6,6),1,C,S) C C TEST THE LINEAR FIT FOR ILL-CONDITIONING C 14 DMIN = AMIN1( ABS(A(4,4)),ABS(A(5,5)) ) IF (DMIN .LT. DTOL) GO TO 17 C C SOLVE THE 2 BY 2 TRIANGULAR SYSTEM FOR THE DERIVATIVES C 15 DY = A(6,5)/A(5,5) DX = (A(6,4) - A(5,4)*DY)/A(4,4)/AV DY = DY/AV IER = LNP - 1 RETURN C C N OR K IS OUT OF RANGE C 16 IER = -1 RETURN C C NO UNIQUE SOLUTION DUE TO COLLINEAR NODES C 17 IER = -2 RETURN END SUBROUTINE SETRM (XK,YK,ZK,XI,YI,ZI,S1,S2,R, ROW) REAL XK, YK, ZK, XI, YI, ZI, S1, S2, R, ROW(6) C C*********************************************************** C C ROBERT RENKA C OAK RIDGE NATL. LAB. C (615) 576-5139 C C THIS ROUTINE SETS UP THE I-TH ROW OF AN AUGMENTED RE- C GRESSION MATRIX FOR A WEIGHTED LEAST-SQUARES FIT OF A C QUADRATIC FUNCTION Q(X,Y) TO A SET OF DATA VALUES Z WHERE C Q(XK,YK) = ZK. THE FIRST 3 COLUMNS (QUADRATIC TERMS) ARE C SCALED BY 1/S2 AND THE FOURTH AND FIFTH COLUMNS (LINEAR C TERMS) ARE SCALED BY 1/S1. THE WEIGHT IS (R-D)/(R*D) IF C R .GT. D AND 0 IF R .LE. D, WHERE D IS THE DISTANCE C BETWEEN NODES I AND K. C C INPUT PARAMETERS - XK,YK,ZK - COORDINATES AND DATA VALUE C AT NODE K -- INTERPOLATED C BY Q. C C XI,YI,ZI - COORDINATES AND DATA VALUE C AT NODE I. C C S1,S2 - INVERSE SCALE FACTORS. C C R - RADIUS OF INFLUENCE ABOUT C NODE K DEFINING THE WEIGHT. C C ROW - VECTOR OF LENGTH 6. C C INPUT PARAMETERS ARE NOT ALTERED BY THIS ROUTINE. C C OUTPUT PARAMETER - ROW - VECTOR CONTAINING A ROW OF THE C AUGMENTED REGRESSION MATRIX. C C MODULES REFERENCED BY SETRM - NONE C C INTRINSIC FUNCTION CALLED BY SETRM - SQRT C C*********************************************************** C INTEGER I REAL DX, DY, DXSQ, DYSQ, D, W, W1, W2 C C LOCAL PARAMETERS - C C I = DO-LOOP INDEX C DX = XI - XK C DY = YI - YK C DXSQ = DX*DX C DYSQ = DY*DY C D = DISTANCE BETWEEN NODES K AND I C W = WEIGHT ASSOCIATED WITH THE ROW C W1 = W/S1 C W2 = W/S2 C DX = XI - XK DY = YI - YK DXSQ = DX*DX DYSQ = DY*DY D = SQRT(DXSQ + DYSQ) IF (D .LE. 0. .OR. D .GE. R) GO TO 1 W = (R-D)/R/D W1 = W/S1 W2 = W/S2 ROW(1) = DXSQ*W2 ROW(2) = DX*DY*W2 ROW(3) = DYSQ*W2 ROW(4) = DX*W1 ROW(5) = DY*W1 ROW(6) = (ZI - ZK)*W RETURN C C NODES K AND I COINCIDE OR NODE I IS OUTSIDE OF THE RADIUS C OF INFLUENCE. SET ROW TO THE ZERO VECTOR. C 1 DO 2 I = 1,6 2 ROW(I) = 0. RETURN END SUBROUTINE GETNP (X,Y,IADJ,IEND,L, NPTS, DS,IER) INTEGER IADJ(*), IEND(*), L, NPTS(L), IER REAL X(*), Y(*), DS C C*********************************************************** C C ROBERT RENKA C OAK RIDGE NATL. LAB. C (615) 576-5139 C C GIVEN A THIESSEN TRIANGULATION OF N NODES AND AN ARRAY C NPTS CONTAINING THE INDICES OF L-1 NODES ORDERED BY C EUCLIDEAN DISTANCE FROM NPTS(1), THIS SUBROUTINE SETS C NPTS(L) TO THE INDEX OF THE NEXT NODE IN THE SEQUENCE -- C THE NODE, OTHER THAN NPTS(1),...,NPTS(L-1), WHICH IS C CLOSEST TO NPTS(1). THUS, THE ORDERED SEQUENCE OF K C CLOSEST NODES TO N1 (INCLUDING N1) MAY BE DETERMINED BY C K-1 CALLS TO GETNP WITH NPTS(1) = N1 AND L = 2,3,...,K C FOR K .GE. 2. C THE ALGORITHM USES THE FACT THAT, IN A THIESSEN TRIAN- C GULATION, THE K-TH CLOSEST NODE TO A GIVEN NODE N1 IS A C NEIGHBOR OF ONE OF THE K-1 CLOSEST NODES TO N1. C C INPUT PARAMETERS - X,Y - VECTORS OF LENGTH N CONTAINING C THE CARTESIAN COORDINATES OF THE C NODES. C C IADJ - SET OF ADJACENCY LISTS OF NODES C IN THE TRIANGULATION. C C IEND - POINTERS TO THE ENDS OF ADJACENCY C LISTS FOR EACH NODE IN THE TRI- C ANGULATION. C C L - NUMBER OF NODES IN THE SEQUENCE C ON OUTPUT. 2 .LE. L .LE. N. C C NPTS - ARRAY OF LENGTH .GE. L CONTAIN- C ING THE INDICES OF THE L-1 CLOS- C EST NODES TO NPTS(1) IN THE FIRST C L-1 LOCATIONS. C C IADJ AND IEND MAY BE CREATED BY SUBROUTINE TRMESH. C C INPUT PARAMETERS OTHER THAN NPTS ARE NOT ALTERED BY THIS C ROUTINE. C C OUTPUT PARAMETERS - NPTS - UPDATED WITH THE INDEX OF THE C L-TH CLOSEST NODE TO NPTS(1) IN C POSITION L UNLESS IER = 1. C C DS - SQUARED EUCLIDEAN DISTANCE BE- C TWEEN NPTS(1) AND NPTS(L) C UNLESS IER = 1. C C IER - ERROR INDICATOR C IER = 0 IF NO ERRORS WERE EN- C COUNTERED. C IER = 1 IF L IS OUT OF RANGE. C C MODULES REFERENCED BY GETNP - NONE C C INTRINSIC FUNCTION CALLED BY GETNP - IABS C C*********************************************************** C INTEGER LM1, N1, I, NI, NP, INDF, INDL, INDX, NB REAL X1, Y1, DNP, DNB C C LOCAL PARAMETERS - C C LM1 = L - 1 C N1 = NPTS(1) C I = NPTS INDEX AND DO-LOOP INDEX C NI = NPTS(I) C NP = CANDIDATE FOR NPTS(L) C INDF = IADJ INDEX OF THE FIRST NEIGHBOR OF NI C INDL = IADJ INDEX OF THE LAST NEIGHBOR OF NI C INDX = IADJ INDEX IN THE RANGE INDF,...,INDL C NB = NEIGHBOR OF NI AND CANDIDATE FOR NP C X1,Y1 = COORDINATES OF N1 C DNP,DNB = SQUARED DISTANCES FROM N1 TO NP AND NB, C RESPECTIVELY C LM1 = L - 1 IF (LM1 .LT. 1) GO TO 4 IER = 0 N1 = NPTS(1) X1 = X(N1) Y1 = Y(N1) C C MARK THE ELEMENTS OF NPTS C DO 1 I = 1,LM1 NI = NPTS(I) IEND(NI) = -IEND(NI) 1 CONTINUE C C CANDIDATES FOR NP = NPTS(L) ARE THE UNMARKED NEIGHBORS C OF NODES IN NPTS. NP=0 IS A FLAG TO SET NP TO THE C FIRST CANDIDATE ENCOUNTERED. C NP = 0 DNP = 0. C C LOOP ON NODES NI IN NPTS C DO 2 I = 1,LM1 NI = NPTS(I) INDF = 1 IF (NI .GT. 1) INDF = IABS(IEND(NI-1)) + 1 INDL = -IEND(NI) C C LOOP ON NEIGHBORS NB OF NI C DO 2 INDX = INDF,INDL NB = IADJ(INDX) IF (NB .EQ. 0 .OR. IEND(NB) .LT. 0) GO TO 2 C C NB IS AN UNMARKED NEIGHBOR OF NI. REPLACE NP IF NB IS C CLOSER TO N1 OR IS THE FIRST CANDIDATE ENCOUNTERED. C DNB = (X(NB)-X1)**2 + (Y(NB)-Y1)**2 IF (NP .NE. 0 .AND. DNB .GE. DNP) GO TO 2 NP = NB DNP = DNB 2 CONTINUE NPTS(L) = NP DS = DNP C C UNMARK THE ELEMENTS OF NPTS C DO 3 I = 1,LM1 NI = NPTS(I) IEND(NI) = -IEND(NI) 3 CONTINUE RETURN C C L IS OUT OF RANGE C 4 IER = 1 RETURN END SUBROUTINE SFVAL (N, X, Y, Z, M, XI, YI, ZI, IADJ, IEND, * ZXZY, IERR) C----------------------------------------------------------------------- C EVALUATION OF THE SURFACE C----------------------------------------------------------------------- REAL X(N), Y(N), Z(N), XI(M), YI(M), ZI(M), ZXZY(2,N) INTEGER IADJ(*), IEND(N) C IF (N .LT. 3 .OR. M .LT. 1) GO TO 20 C IST = 1 DO 10 J = 1,M CALL INTRC1 (N, XI(J), YI(J), X, Y, Z, IADJ, IEND, * 1, ZXZY, IST, ZI(J), IERR) IF (IERR .LT. 0) GO TO 30 10 CONTINUE IERR = 0 RETURN C C ERROR RETURN C 20 IERR = 1 RETURN 30 IERR = 2 RETURN END SUBROUTINE SFVAL2 (N, X, Y, Z, L, M, NROWS, XI, YI, ZI, * IADJ, IEND, ZXZY, IERR) C----------------------------------------------------------------------- C EVALUATION OF THE SURFACE OVER A GRID C----------------------------------------------------------------------- REAL X(N), Y(N), Z(N), ZXZY(2,N) REAL XI(L), YI(M), ZI(NROWS,M) INTEGER IADJ(*), IEND(N) C IF (N .LT. 3 .OR. L .LT. 1 .OR. M .LT. 1 .OR. NROWS .LT. L) * GO TO 30 C IST = 1 DO 20 J = 1,M DO 10 I = 1,L CALL INTRC1 (N, XI(I), YI(J), X, Y, Z, IADJ, IEND, * 1, ZXZY, IST, ZI(I,J), IERR) IF (IERR .LT. 0) GO TO 40 10 CONTINUE 20 CONTINUE IERR = 0 RETURN C C ERROR RETURN C 30 IERR = 1 RETURN 40 IERR = 2 RETURN END SUBROUTINE INTRC1 (N,PX,PY,X,Y,Z,IADJ,IEND,IFLAG, . ZXZY, IST, PZ,IER) INTEGER N, IADJ(*), IEND(N), IFLAG, IST, IER REAL PX, PY, X(N), Y(N), Z(N), ZXZY(2,N), PZ C C*********************************************************** C C ROBERT RENKA C OAK RIDGE NATL. LAB. C (615) 576-5139 C C GIVEN A TRIANGULATION OF A SET OF POINTS IN THE PLANE, C THIS ROUTINE DETERMINES A PIECEWISE CUBIC FUNCTION F(X,Y) C WHICH INTERPOLATES A SET OF DATA VALUES AND PARTIAL C DERIVATIVES AT THE VERTICES. F HAS CONTINUOUS FIRST C DERIVATIVES OVER THE MESH AND EXTENDS BEYOND THE MESH C BOUNDARY ALLOWING EXTRAPOLATION. INTERPOLATION IS EXACT C FOR QUADRATIC DATA. THE VALUE OF F AT (PX,PY) IS C RETURNED. INTRC1 IS PART OF AN INTERPOLATION PACKAGE C WHICH PROVIDES ROUTINES TO GENERATE, UPDATE AND PLOT THE C MESH. C C INPUT PARAMETERS - N - NUMBER OF NODES IN THE MESH. C N .GE. 3. C C PX,PY - COORDINATES OF A POINT AT WHICH C F IS TO BE EVALUATED. C C X,Y - VECTORS OF COORDINATES OF THE C NODES IN THE MESH. C C Z - VECTOR OF DATA VALUES AT THE C NODES. C C IADJ - SET OF ADJACENCY LISTS OF NODES C IN THE MESH. C C IEND - POINTERS TO THE ENDS OF C ADJACENCY LISTS IN IADJ FOR C EACH NODE IN THE MESH. C C IFLAG - OPTION INDICATOR C IFLAG = 0 IF INTRC1 IS TO C PROVIDE DERIVATIVE C ESTIMATES (FROM C GRADL1). C IFLAG = 1 IF DERIVATIVES ARE C USER PROVIDED. C C ZXZY - 2 BY N ARRAY WHOSE COLUMNS C CONTAIN ESTIMATED PARTIAL DER- C IVATIVES AT THE NODES (X PAR- C TIALS IN THE FIRST ROW) IF C IFLAG = 1, NOT USED IF IFLAG C = 0. C C IST - INDEX OF THE STARTING NODE IN C THE SEARCH FOR A TRIANGLE CON- C TAINING (PX,PY). 1 .LE. IST C .LE. N. THE OUTPUT VALUE OF C IST FROM A PREVIOUS CALL MAY C BE A GOOD CHOICE. C C IADJ AND IEND MAY BE CREATED BY TRMESH AND DERIVATIVE C ESTIMATES MAY BE COMPUTED BY GRADL1 OR GRADG. C C INPUT PARAMETERS OTHER THAN IST ARE NOT ALTERED BY THIS C ROUTINE. C C OUTPUT PARAMETERS - IST - INDEX OF ONE OF THE VERTICES OF C THE TRIANGLE CONTAINING (PX,PY) C UNLESS IER .LT. 0. C C PZ - VALUE OF F AT (PX,PY), OR 0 IF C IER .LT. 0. C C IER - ERROR INDICATOR C IER = 0 IF NO ERRORS WERE C ENCOUNTERED. C IER = 1 IF NO ERRORS WERE EN- C COUNTERED AND EXTRAPOLA- C TION WAS PERFORMED. C IER = -1 IF N, IFLAG, OR IST IS C OUT OF RANGE. C IER = -2 IF THE NODES ARE COL- C LINEAR. C C MODULES REFERENCED BY INTRC1 - TRFIND, TVAL, C (AND OPTIONALLY) GRADL1, GETNP, SETRM, C SROTG, SROT C C*********************************************************** C INTEGER NN, I1, I2, I3, IERR, N1, N2, INDX REAL XP, YP, ZX1, ZY1, ZX2, ZY2, ZX3, ZY3, X1, Y1, . X2, Y2, X3, Y3, Z1, Z2, Z3, DUM, DP, U, V, XQ, . YQ, R1, R2, A1, A2, B1, B2, C1, C2, F1, F2 C C LOCAL PARAMETERS - C C NN = LOCAL COPY OF N C I1,I2,I3 = VERTICES DETERMINED BY TRFIND C IERR = ERROR FLAG FOR CALLS TO GRADL1 C AND TVAL C N1,N2 = ENDPOINTS OF THE CLOSEST BOUND- C ARY EDGE TO P WHEN P IS OUT- C SIDE OF THE MESH BOUNDARY C INDX = IADJ INDEX OF N1 AS A NEIGHBOR C OF N2 C XP,YP = LOCAL COPIES OF THE COORDINATES C OF P=(PX,PY) C ZX1,ZY1,ZX2,ZY2,ZX3,ZY3 = X AND Y DERIVATIVES AT THE C VERTICES OF A TRIANGLE T WHICH C CONTAINS P OR AT N1 AND N2 C X1,Y1,X2,Y2,X3,Y3 = X,Y COORDINATES OF THE VERTICES C OF T OR OF N1 AND N2 C Z1,Z2,Z3 = DATA VALUES AT THE VERTICES OF T C DUM = DUMMY VARIABLE FOR CALL TO TVAL C DP = INNER PRODUCT OF N1-N2 AND P-N2 C U,V = X,Y COORDINATES OF THE VECTOR C N2-N1 C XQ,YQ = X,Y COORDINATES OF THE CLOSEST C BOUNDARY POINT TO P WHEN P IS C OUTSIDE OF THE MESH BOUNDARY C R1,R2 = BARYCENTRIC COORDINATES OF Q C WITH RESPECT TO THE LINE SEG- C MENT N2-N1 CONTAINING Q C A1,A2,B1,B2,C1,C2 = CARDINAL FUNCTIONS FOR EVALUAT- C ING THE INTERPOLATORY SURFACE C AT Q C F1,F2 = CUBIC FACTORS USED TO COMPUTE C THE CARDINAL FUNCTIONS C NN = N PZ = 0. IF (NN .LT. 3 .OR. IFLAG .LT. 0 .OR. IFLAG .GT. 1 . .OR. IST .LT. 1 .OR. IST .GT. NN) GO TO 11 XP = PX YP = PY C C FIND A TRIANGLE CONTAINING P IF P IS WITHIN THE MESH C BOUNDARY C CALL TRFIND(IST,XP,YP,X,Y,IADJ,IEND, I1,I2,I3) IF (I1 .EQ. 0) GO TO 12 IST = I1 IF (I3 .EQ. 0) GO TO 3 IF (IFLAG .NE. 1) GO TO 1 C C DERIVATIVES ARE USER PROVIDED C ZX1 = ZXZY(1,I1) ZX2 = ZXZY(1,I2) ZX3 = ZXZY(1,I3) ZY1 = ZXZY(2,I1) ZY2 = ZXZY(2,I2) ZY3 = ZXZY(2,I3) GO TO 2 C C COMPUTE DERIVATIVE ESTIMATES AT THE VERTICES C 1 CALL GRADL1(NN,I1,X,Y,Z,IADJ,IEND, ZX1,ZY1,IERR) CALL GRADL1(NN,I2,X,Y,Z,IADJ,IEND, ZX2,ZY2,IERR) CALL GRADL1(NN,I3,X,Y,Z,IADJ,IEND, ZX3,ZY3,IERR) C C SET LOCAL PARAMETERS FOR CALL TO TVAL C 2 X1 = X(I1) Y1 = Y(I1) X2 = X(I2) Y2 = Y(I2) X3 = X(I3) Y3 = Y(I3) Z1 = Z(I1) Z2 = Z(I2) Z3 = Z(I3) CALL TVAL(XP,YP,X1,X2,X3,Y1,Y2,Y3,Z1,Z2,Z3,ZX1,ZX2, . ZX3,ZY1,ZY2,ZY3,0, PZ,DUM,DUM,IERR) IF (IERR .NE. 0) GO TO 12 IER = 0 RETURN C C P IS OUTSIDE OF THE MESH BOUNDARY. EXTRAPOLATE TO P BY C PASSING A LINEAR FUNCTION OF ONE VARIABLE THROUGH THE C VALUE AND DIRECTIONAL DERIVATIVE (IN THE DIRECTION C P-Q) OF THE INTERPOLATORY SURFACE (TVAL) AT Q WHERE C Q IS THE CLOSEST BOUNDARY POINT TO P. C C DETERMINE Q BY TRAVERSING THE BOUNDARY STARTING FROM C THE RIGHTMOST VISIBLE NODE I1. C 3 N2 = I1 C C SET N1 TO THE LAST NONZERO NEIGHBOR OF N2 AND COMPUTE DP C 4 INDX = IEND(N2) - 1 N1 = IADJ(INDX) X1 = X(N1) Y1 = Y(N1) X2 = X(N2) Y2 = Y(N2) DP = (X1-X2)*(XP-X2) + (Y1-Y2)*(YP-Y2) IF (DP .LE. 0.) GO TO 5 IF ((XP-X1)*(X2-X1) + (YP-Y1)*(Y2-Y1) .GT. 0.) GO TO 8 N2 = N1 GO TO 4 C C N2 IS THE CLOSEST BOUNDARY POINT TO P. COMPUTE PARTIAL C DERIVATIVES AT N2. C 5 IF (IFLAG .NE. 1) GO TO 6 ZX2 = ZXZY(1,N2) ZY2 = ZXZY(2,N2) GO TO 7 6 CALL GRADL1(NN,N2,X,Y,Z,IADJ,IEND, ZX2,ZY2,IERR) C C COMPUTE EXTRAPOLATED VALUE AT P C 7 PZ = Z(N2) + ZX2*(XP-X2) + ZY2*(YP-Y2) IER = 1 RETURN C C THE CLOSEST BOUNDARY POINT Q LIES ON N2-N1. COMPUTE C PARTIALS AT N1 AND N2. C 8 IF (IFLAG .NE. 1) GO TO 9 ZX1 = ZXZY(1,N1) ZY1 = ZXZY(2,N1) ZX2 = ZXZY(1,N2) ZY2 = ZXZY(2,N2) GO TO 10 9 CALL GRADL1(NN,N1,X,Y,Z,IADJ,IEND, ZX1,ZY1,IERR) CALL GRADL1(NN,N2,X,Y,Z,IADJ,IEND, ZX2,ZY2,IERR) C C COMPUTE Q, ITS BARYCENTRIC COORDINATES, AND THE CARDINAL C FUNCTIONS FOR EXTRAPOLATION C 10 U = X2-X1 V = Y2-Y1 R1 = DP/(U**2 + V**2) R2 = 1. - R1 XQ = R1*X1 + R2*X2 YQ = R1*Y1 + R2*Y2 F1 = R1*R1*R2 F2 = R1*R2*R2 A1 = R1 + (F1-F2) A2 = R2 - (F1-F2) B1 = U*F1 B2 = -U*F2 C1 = V*F1 C2 = -V*F2 C C COMPUTE THE VALUE OF THE INTERPOLATORY SURFACE (TVAL) C AT Q C PZ = A1*Z(N1) + A2*Z(N2) + B1*ZX1 + B2*ZX2 + . C1*ZY1 + C2*ZY2 C C COMPUTE THE EXTRAPOLATED VALUE AT P C PZ = PZ + (R1*ZX1 + R2*ZX2)*(XP-XQ) + . (R1*ZY1 + R2*ZY2)*(YP-YQ) IER = 1 RETURN C C N, IFLAG, OR IST OUT OF RANGE C 11 IER = -1 RETURN C C NODES ARE COLLINEAR C 12 IER = -2 RETURN END SUBROUTINE TVAL (X,Y,X1,X2,X3,Y1,Y2,Y3,Z1,Z2,Z3,ZX1, . ZX2,ZX3,ZY1,ZY2,ZY3,IFLAG, W,WX,WY, . IER) INTEGER IFLAG, IER REAL X, Y, X1, X2, X3, Y1, Y2, Y3, Z1, Z2, Z3, . ZX1, ZX2, ZX3, ZY1, ZY2, ZY3, W, WX, WY C C*********************************************************** C C ROBERT RENKA C OAK RIDGE NATL. LAB. C (615) 576-5139 C C GIVEN FUNCTION VALUES AND FIRST PARTIAL DERIVATIVES AT C THE THREE VERTICES OF A TRIANGLE, THIS ROUTINE DETERMINES C A FUNCTION W WHICH AGREES WITH THE GIVEN DATA, RETURNING C THE VALUE AND (OPTIONALLY) FIRST PARTIAL DERIVATIVES OF W C AT A POINT (X,Y) IN THE TRIANGLE. THE INTERPOLATION C METHOD IS EXACT FOR QUADRATIC POLYNOMIAL DATA. THE C TRIANGLE IS PARTITIONED INTO THREE SUBTRIANGLES WITH C EQUAL AREAS. W IS CUBIC IN EACH SUBTRIANGLE AND ALONG C THE EDGES, BUT HAS ONLY ONE CONTINUOUS DERIVATIVE ACROSS C EDGES. THE NORMAL DERIVATIVE OF W VARIES LINEARLY ALONG C EACH OUTER EDGE. THE VALUES AND PARTIAL DERIVATIVES OF W C ALONG A TRIANGLE EDGE DEPEND ONLY ON THE DATA VALUES AT C THE ENDPOINTS OF THE EDGE. THUS THE METHOD YIELDS C-1 C CONTINUITY WHEN USED TO INTERPOLATE OVER A TRIANGULAR C GRID. THIS ALGORITHM IS DUE TO C. L. LAWSON. C C INPUT PARAMETERS - X,Y - COORDINATES OF A POINT AT WHICH C W IS TO BE EVALUATED. C C X1,X2,X3,Y1,Y2,Y3 - COORDINATES OF THE VERTICES OF C A TRIANGLE CONTAINING (X,Y). C C Z1,Z2,Z3 - FUNCTION VALUES AT THE VERTICES C TO BE INTERPOLATED. C C ZX1,ZX2,ZX3 - X-DERIVATIVE VALUES AT THE C VERTICES. C C ZY1,ZY2,ZY3 - Y-DERIVATIVE VALUES AT THE C VERTICES. C C IFLAG - OPTION INDICATOR C IFLAG = 0 IF ONLY W IS TO BE C COMPUTED. C IFLAG = 1 IF W, WX, AND WY ARE C TO BE RETURNED. C C INPUT PARAMETERS ARE NOT ALTERED BY THIS ROUTINE. C C OUTPUT PARAMETERS - W - ESTIMATED VALUE OF THE INTERP- C OLATORY FUNCTION AT (X,Y) IF C IER = 0. OTHERWISE W = 0. C C WX,WY - PARTIAL DERIVATIVES OF W AT C (X,Y) IF IER = 0 AND IFLAG = 1, C UNCHANGED IF IFLAG .NE. 1, ZERO C IF IER .NE. 0 AND IFLAG = 1. C C IER - ERROR INDICATOR C IER = 0 IF NO ERRORS WERE C ENCOUNTERED. C IER = 1 IF THE VERTICES OF THE C TRIANGLE ARE COLLINEAR. C C MODULES REFERENCED BY TVAL - NONE C C INTRINSIC FUNCTION CALLED BY TVAL - AMIN1 C C*********************************************************** C INTEGER I, IP1, IP2, IP3 REAL U(3), V(3), SL(3), AREA, XP, YP, R(3), RX(3), . RY(3), PHI(3), PHIX(3), PHIY(3), RMIN, C1, C2, . RO(3), ROX(3), ROY(3), F(3), G(3), GX(3), . GY(3), P(3), PX(3), PY(3), Q(3), QX(3), QY(3), . A(3), AX(3), AY(3), B(3), BX(3), BY(3), C(3), . CX(3), CY(3) C C LOCAL PARAMETERS - C C I = DO-LOOP INDEX C IP1,IP2,IP3 = PERMUTED INDICES FOR COMPUTING RO, ROX, C AND ROY C U(K) = X-COMPONENT OF THE VECTOR REPRESENTING C THE SIDE OPPOSITE VERTEX K C V(K) = Y-COMPONENT OF THE VECTOR REPRESENTING C THE SIDE OPPOSITE VERTEX K C SL(K) = SQUARE OF THE LENGTH OF THE SIDE C OPPOSITE VERTEX K C AREA = TWICE THE AREA OF THE TRIANGLE C XP,YP = X-X1, Y-Y1 C R(K) = K-TH BARYCENTRIC COORDINATE C RX(K),RY(K) = X,Y PARTIAL DERIVATIVES OF R(K) C PHI(K) R(K-1)*R(K+1) -- QUADRATIC C PHIX(K),PHIY(K) = X,Y PARTIALS OF PHI(K) C RMIN = MIN(R1,R2,R3) C C1,C2 = FACTORS FOR COMPUTING RO C RO(K) = FACTORS FOR COMPUTING G -- CUBIC C CORRECTION TERMS C ROX(K),ROY(K) = X,Y PARTIALS OF RO(K) C F(K) = FACTORS FOR COMPUTING G, GX, AND GY -- C CONSTANT C G(K) = FACTORS FOR COMPUTING THE CARDINAL C FUNCTIONS -- CUBIC C GX(K),GY(K) = X,Y PARTIALS OF G(K) C P(K) = G(K) + PHI(K) C PX(K),PY(K) = X,Y PARTIALS OF P(K) C Q(K) = G(K) - PHI(K) C QX(K),QY(K) = X,Y PARTIALS OF Q(K) C A(K) = CARDINAL FUNCTION WHOSE COEFFICIENT IS C Z(K) C AX(K),AY(K) = X,Y PARTIALS OF A(K) -- CARDINAL C FUNCTIONS FOR WX AND WY C B(K) = TWICE THE CARDINAL FUNCTION WHOSE C COEFFICIENT IS ZX(K) C BX(K),BY(K) = X,Y PARTIALS OF B(K) C C(K) = TWICE THE CARDINAL FUNCTION WHOSE C COEFFICIENT IS ZY(K) C CX(K),CY(K) = X,Y PARTIALS OF C(K) C U(1) = X3 - X2 U(2) = X1 - X3 U(3) = X2 - X1 C V(1) = Y3 - Y2 V(2) = Y1 - Y3 V(3) = Y2 - Y1 C DO 1 I = 1,3 SL(I) = U(I)*U(I) + V(I)*V(I) 1 CONTINUE C C AREA = 3-1 X 3-2 C AREA = U(1)*V(2) - U(2)*V(1) IF (AREA .EQ. 0.) GO TO 9 C C R(1) = (2-3 X 2-(X,Y))/AREA, R(2) = (1-(X,Y) X 1-3)/AREA, C R(3) = (1-2 X 1-(X,Y))/AREA C R(1) = (U(1)*(Y-Y2) - V(1)*(X-X2))/AREA XP = X - X1 YP = Y - Y1 R(2) = (U(2)*YP - V(2)*XP)/AREA R(3) = (U(3)*YP - V(3)*XP)/AREA IER = 0 C PHI(1) = R(2)*R(3) PHI(2) = R(3)*R(1) PHI(3) = R(1)*R(2) C RMIN = AMIN1(R(1),R(2),R(3)) IF (RMIN .NE. R(1)) GO TO 3 IP1 = 1 IP2 = 2 IP3 = 3 GO TO 5 3 IF (RMIN .NE. R(2)) GO TO 4 IP1 = 2 IP2 = 3 IP3 = 1 GO TO 5 4 IP1 = 3 IP2 = 1 IP3 = 2 C 5 C1 = RMIN*RMIN/2. C2 = RMIN/3. RO(IP1) = (PHI(IP1) + 5.*C1/3.)*R(IP1) - C1 RO(IP2) = C1*(R(IP3) - C2) RO(IP3) = C1*(R(IP2) - C2) C F(1) = 3.*(SL(2)-SL(3))/SL(1) F(2) = 3.*(SL(3)-SL(1))/SL(2) F(3) = 3.*(SL(1)-SL(2))/SL(3) C G(1) = (R(2)-R(3))*PHI(1) + F(1)*RO(1) - RO(2) + RO(3) G(2) = (R(3)-R(1))*PHI(2) + F(2)*RO(2) - RO(3) + RO(1) G(3) = (R(1)-R(2))*PHI(3) + F(3)*RO(3) - RO(1) + RO(2) C DO 6 I = 1,3 P(I) = G(I) + PHI(I) Q(I) = G(I) - PHI(I) 6 CONTINUE C A(1) = R(1) + G(3) - G(2) A(2) = R(2) + G(1) - G(3) A(3) = R(3) + G(2) - G(1) C B(1) = U(3)*P(3) + U(2)*Q(2) B(2) = U(1)*P(1) + U(3)*Q(3) B(3) = U(2)*P(2) + U(1)*Q(1) C C(1) = V(3)*P(3) + V(2)*Q(2) C(2) = V(1)*P(1) + V(3)*Q(3) C(3) = V(2)*P(2) + V(1)*Q(1) C C W IS A LINEAR COMBINATION OF THE CARDINAL FUNCTIONS C W = A(1)*Z1 + A(2)*Z2 + A(3)*Z3 + (B(1)*ZX1 + B(2)*ZX2 . + B(3)*ZX3 + C(1)*ZY1 + C(2)*ZY2 + C(3)*ZY3)/2. IF (IFLAG .NE. 1) RETURN C C COMPUTE WX AND WY C DO 7 I = 1,3 RX(I) = -V(I)/AREA RY(I) = U(I)/AREA 7 CONTINUE PHIX(1) = R(2)*RX(3) + RX(2)*R(3) PHIY(1) = R(2)*RY(3) + RY(2)*R(3) PHIX(2) = R(3)*RX(1) + RX(3)*R(1) PHIY(2) = R(3)*RY(1) + RY(3)*R(1) PHIX(3) = R(1)*RX(2) + RX(1)*R(2) PHIY(3) = R(1)*RY(2) + RY(1)*R(2) C ROX(IP1) = RX(IP1)*(PHI(IP1) + 5.*C1) + . R(IP1)*(PHIX(IP1) - RX(IP1)) ROY(IP1) = RY(IP1)*(PHI(IP1) + 5.*C1) + . R(IP1)*(PHIY(IP1) - RY(IP1)) ROX(IP2) = RX(IP1)*(PHI(IP2) - C1) + C1*RX(IP3) ROY(IP2) = RY(IP1)*(PHI(IP2) - C1) + C1*RY(IP3) ROX(IP3) = RX(IP1)*(PHI(IP3) - C1) + C1*RX(IP2) ROY(IP3) = RY(IP1)*(PHI(IP3) - C1) + C1*RY(IP2) C GX(1) = (RX(2) - RX(3))*PHI(1) + (R(2) - R(3))*PHIX(1) . + F(1)*ROX(1) - ROX(2) + ROX(3) GY(1) = (RY(2) - RY(3))*PHI(1) + (R(2) - R(3))*PHIY(1) . + F(1)*ROY(1) - ROY(2) + ROY(3) GX(2) = (RX(3) - RX(1))*PHI(2) + (R(3) - R(1))*PHIX(2) . + F(2)*ROX(2) - ROX(3) + ROX(1) GY(2) = (RY(3) - RY(1))*PHI(2) + (R(3) - R(1))*PHIY(2) . + F(2)*ROY(2) - ROY(3) + ROY(1) GX(3) = (RX(1) - RX(2))*PHI(3) + (R(1) - R(2))*PHIX(3) . + F(3)*ROX(3) - ROX(1) + ROX(2) GY(3) = (RY(1) - RY(2))*PHI(3) + (R(1) - R(2))*PHIY(3) . + F(3)*ROY(3) - ROY(1) + ROY(2) C DO 8 I = 1,3 PX(I) = GX(I) + PHIX(I) PY(I) = GY(I) + PHIY(I) QX(I) = GX(I) - PHIX(I) QY(I) = GY(I) - PHIY(I) 8 CONTINUE C AX(1) = RX(1) + GX(3) - GX(2) AY(1) = RY(1) + GY(3) - GY(2) AX(2) = RX(2) + GX(1) - GX(3) AY(2) = RY(2) + GY(1) - GY(3) AX(3) = RX(3) + GX(2) - GX(1) AY(3) = RY(3) + GY(2) - GY(1) C BX(1) = U(3)*PX(3) + U(2)*QX(2) BY(1) = U(3)*PY(3) + U(2)*QY(2) BX(2) = U(1)*PX(1) + U(3)*QX(3) BY(2) = U(1)*PY(1) + U(3)*QY(3) BX(3) = U(2)*PX(2) + U(1)*QX(1) BY(3) = U(2)*PY(2) + U(1)*QY(1) C CX(1) = V(3)*PX(3) + V(2)*QX(2) CY(1) = V(3)*PY(3) + V(2)*QY(2) CX(2) = V(1)*PX(1) + V(3)*QX(3) CY(2) = V(1)*PY(1) + V(3)*QY(3) CX(3) = V(2)*PX(2) + V(1)*QX(1) CY(3) = V(2)*PY(2) + V(1)*QY(1) C C WX AND WY ARE LINEAR COMBINATIONS OF THE CARDINAL C FUNCTIONS C WX = AX(1)*Z1 + AX(2)*Z2 + AX(3)*Z3 + (BX(1)*ZX1 + . BX(2)*ZX2 + BX(3)*ZX3 + CX(1)*ZY1 + CX(2)*ZY2 + . CX(3)*ZY3)/2. WY = AY(1)*Z1 + AY(2)*Z2 + AY(3)*Z3 + (BY(1)*ZX1 + . BY(2)*ZX2 + BY(3)*ZX3 + CY(1)*ZY1 + CY(2)*ZY2 + . CY(3)*ZY3)/2. RETURN C C VERTICES ARE COLLINEAR C 9 IER = 1 W = 0. IF (IFLAG .NE. 1) RETURN WX = 0. WY = 0. RETURN END SUBROUTINE MFIT(DIMEN,FITDEG,NFPOLS,NFPTS, + FITCDS,NCROWS,FITVLS,WTS, + RESIDS,ERROR,FITIWK,FITDWK, + FIWKLN,FDWKLN,IREQD,DREQD) C INTEGER NFPOLS,FITDEG,NFPTS,DIMEN,FIWKLN,FDWKLN INTEGER ERROR,IREQD,DREQD,INDSTT,P,DIMP1,NCROWS INTEGER NEWSTT,MAXSTT,ALFSTT,PSISTT,CSTT,SSQSTT,PSIWID,ALFL INTEGER FITIWK(FIWKLN) REAL FITDWK(FDWKLN),FITCDS(NCROWS,DIMEN) REAL FITVLS(NFPTS),RESIDS(NFPTS) REAL WTS(NFPTS) REAL SCALE C C *************** C PURPOSE C ------- C C THIS SUBROUTINE CONSTRUCTS A LEAST-SQUARES MULTINOMIAL FIT TO C GIVEN DATA USING A BASIS OF ORTHOGONAL MULTINOMIALS. C C THE DATA FOR THE FIT IS GIVEN IN THE ARRAYS FITCDS, FITVLS, AND C WTS. FITCDS IS A MATRIX, EACH ROW OF WHICH CONTAINS AN OBSERVA- C TION POINT. FITVLS IS A SINGLY-INDEXED ARRAY, EACH ELEMENT OF C WHICH CONTAINS A FUNCTION VALUE CORRESPONDING TO AN OBSERVATION C POINT. WTS IS A SINGLY-INDEXED ARRAY, EACH ELEMENT OF WHICH IS C A NONNEGATIVE WEIGHT FOR THE CORRESPONDING OBSERVATION. C C THE FIT WHICH IS PRODUCED IS A MULTINOMIAL EXPRESSED IN THE FORM C C C PSI (X ,...,X ) +...+ C PSI (X ,...,X ) C 1 1 1 DIMEN NFPOLS NFPOLS 1 DIMEN C C WHERE THE VALUE OF NFPOLS WILL BE AS GIVEN (IF FITDEG .LT. 0) C OR AS COMPUTED BY MFIT TO GIVE A FULL-DEGREE FIT (IN CASE C FITDEG IS SPECIFIED .GE. 0). THE ELEMENTS C C PSI (X ,...,X ) C K 1 DIMEN C C FORM A BASIS FOR THE MULTINOMIALS WHICH IS ORTHOGONAL WITH C RESPECT TO THE WEIGHTS AND OBSERVATION POINTS. C C THE EXTENT OF THE FIT CAN BE SPECIFIED IN ONE OF TWO WAYS. C IF THE PARAMETER FITDEG IS SET .GE. 0, THEN A COMPLETE BASIS C FOR THE MULTINOMIALS OF DEGREE = FITDEG WILL BE USED. (AN C ERROR WILL BE FLAGGED IF THIS WILL REQUIRE MORE BASIS C MULTINOMIALS THAN THE NUMBER OF DATA POINTS WHICH WERE C GIVEN.) C IF THE PARAMETER FITDEG IS .LT. 0, THEN NFPOLS WILL BE C TAKEN AS THE COUNT OF THE NUMBER OF BASIS MULTINOMIALS TO BE C USED FOR A PARTIAL-DEGREE FIT. (AN ERROR WILL BE FLAGGED IF C NFPOLS .LT. 0.) C C VARIABLES C --------- C C DIMEN -- (INTEGER) -- (PASSED) C THE NUMBER OF VARIABLES. C FITDEG - (INTEGER) -- (PASSED/RETURNED) C IGNORED IF .LT. 0. C IF FITDEG .GE. 0 THEN FITDEG IS CHECKED AGAINST NFPTS . C THE VALUE OF FITDEG WILL BE REDUCED IF THERE IS A BASIS OF C MULTINOMIALS, ALL OF DEGREE .LE. FITDEG , OF CARDINALITY C NFPTS . SEE ERROR BELOW. C NFPOLS - (INTEGER) -- (PASSED/RETURNED) C IGNORED IF FITDEG .GE. 0. C IF FITDEG .LT. 0 THEN THE VALUE OF NFPOLS WILL BE TAKEN AS C THE SIZE OF THE BASIS OF MULTINOMIALS TO BE USED IN THE FIT. C NFPOLS MUST SATISFY NFPOLS .LT. NFPTS AND NFPOLS .GE. 1 C SEE ERROR BELOW. C NFPTS --- (INTEGER) -- (PASSED) C THE NUMBER OF DATA POINTS TO BE USED IN THE FIT. C NFPTS MUST BE .GE. 1. SEE ERROR BELOW. C FITCDS -- (REAL 2-SUBSCRIPT ARRAY) -- (PASSED) C FITCDS (P,K) IS THE VALUE OF THE K-TH VARIABLE AT THE P-TH C DATA POINT. C NCROWS -- (INTEGER) -- (PASSED) C THE ROW DIMENSION DECLARED FOR FITCDS IN THE CALLING C PROGRAM. C FITVLS -- (REAL 1-SUBSCRIPT ARRAY) -- (PASSED) C FITVLS (P) IS THE OBSERVED FUNCTION VALUE OF THE P-TH DATA C POINT. C WTS ----- (REAL 1-SUBSCRIPT ARRAY) -- (PASSED) C WTS (P) IS THE WEIGHT ATTACHED TO THE P-TH DATA POINT. C RESIDS -- (REAL 1-SUBSCRIPT ARRAY) -- (RETURNED) C RESIDS (P) IS THE DIFFERENCE BETWEEN THE FITTED FUNCTION AT C POINT P AND FITVLS (P). C ERROR -- (INTEGER) -- (RETURNED) C 0 THE DESIRED LEAST SQUARE MULTINOMIAL FIT WAS OBTAINED. C -1 ONLY THE FIRST NFPOLS BASIS POLYNOMIALS WERE OBTAINED. C FITDEG IS THE DEGREE OF THE FIT. C 1 IF FITDEG .GE. 0 BUT THERE IS AN INTERPOLATING MULTINOMIAL C OF SMALLER DEGREE OR IF FITDEG .LT. 0 AND NFPOLS .GT. NFPTS. C 2 IF FITDEG .LT. 0 AND NFPOLS .LE. 0. C 3 IF NFPTS .LT. 1 AND/OR DIMEN .LT. 1. C 4 IF IWKLEN AND/OR DWKLEN IS TOO SMALL. (SET IWKLEN TO C THE VALUE RETURNED IN IREQD , AND SET DWKLEN TO THE VALUE C RETURNED IN DREQD TO RESOLVE THIS PROBLEM.) C FITIWK -- (INTEGER, 1-SUBSCRIPT ARRAY) -- (RETURNED) C AN INTEGER WORK ARRAY OF LENGTH FIWKLN . UPON RETURN FROM C MFIT, FITIWK CONTAINS DIMENSION AND ARRAY LENGTH INFORMATION. C FITDWK -- (REAL 1-SUBSCRIPT ARRAY) -- (RETURNED) C A REAL ARRAY OF LENGTH FDWKLN CONTAINING THE COEFFICIENTS C NEEDED FOR COMPUTING THE MULTINOMIAL FIT AT A POINT. C FIWKLN -- (INTEGER) -- (PASSED) C THE LENGTH OF THE ARRAY FITIWK . C FDWKLN -- (INTEGER) -- (PASSED) C THE LENGTH OF THE ARRAY FITDWK . C IREQD -- (INTEGER) -- (RETURNED) C THE LENGTH WHICH THE ARRAY FITIWK REALLY NEEDS TO BE. C DREQD -- (INTEGER) -- (RETURNED) C THE LENGTH WHICH THE ARRAY FITDWK REALLY NEEDS TO BE. C C C NOTE. THE 20 LOOP DEPENDS ON THE SCALING SCHEME BEING USED. THE C RESIDUAL SCALING MUST BE CONSISTENT WITH THAT DEFINED BY SCALPM C AND SCALDN. C C MFIT CALLS ALLOT AND GNRTP. C **************** C DIMP1 = DIMEN + 1 C C *************** C CALL ALLOT(FITDEG,NFPOLS,NFPTS,DIMEN,FITIWK,FIWKLN,IREQD,DREQD, + ERROR) IF ( ERROR .GE. 2 ) RETURN C IF ( FDWKLN .GE. DREQD ) GO TO 10 ERROR = 4 RETURN 10 CONTINUE C PSIWID = FITIWK(3) ALFL = FITIWK(4) INDSTT = 1 NEWSTT = 4 * NFPOLS + INDSTT MAXSTT = 1 ALFSTT = MAXSTT + DIMP1 CSTT = ALFSTT + ALFL SSQSTT = CSTT + NFPOLS PSISTT = SSQSTT + NFPOLS C C *************** C CALL GNRTP(FITDEG,FITDWK(ALFSTT), + FITDWK(PSISTT),FITIWK(INDSTT), + FITIWK(NEWSTT),FITDWK(SSQSTT),FITCDS, + NCROWS,NFPOLS,DIMEN,NFPTS,FITVLS,RESIDS, + FITDWK(CSTT),PSIWID,WTS,ALFL,DIMP1, + FITDWK(MAXSTT),ERROR) C C *************** C STORE THE NUMBER OF BASIS POLYNOMIALS ACTUALLY COMPUTED C BY THE MODIFIED ROUTINE INCDG CALLED BY GNRTP. C *************** C FITIWK(1) = NFPOLS C C *************** C UNSCALE THE RESIDUALS FOR THE BENEFIT OF THE USER. C *************** C SCALE = FITDWK(DIMEN + 1) DO 20 P = 1,NFPTS RESIDS(P) = RESIDS(P) * SCALE 20 CONTINUE RETURN END SUBROUTINE ALLOT(DEGREE,NPOLYS,NPTS,DIMEN,IWORK,IWKLEN, + IREQD,DREQD,ERROR) C INTEGER IREQD,DREQD,ALFL,ERROR,NPOLYS,DEGREE,DIMEN,NPTS INTEGER NEWSTT,PSIWID,KMXBAS,STARTJ,KJP1D2,INDEX,IWKLEN INTEGER NPLYT4 INTEGER IWORK(IWKLEN) C C *************** C PURPOSE C ------- C C ALLOT CHECKS FOR SUFFICIENCY THE DECLARED DIMENSIONS OF THE C WORK ARRAYS USED BY THE SUBROUTINE MFIT . VARIOUS SIZES OF C SUB-ARRAYS ARE COMPUTED AND REPORTED. C C THIS ROUTINE IS CALLED BY MFIT . IT IS NOT CALLED DIRECTLY C BY THE USER. C C THIS ROUTINE CALLS BASIZ AND MTABLE FOR THE SUBSTANTIVE C COMPUTATIONS. C C VARIABLES C --------- C C DEGREE - (PASSED/RETURNED) C IGNORED IF .LT. 0. C IF DEGREE .GE. 0 THEN DEGREE IS CHECKED AGAINST NPTS . C THE VALUE OF DEGREE WILL BE REDUCED IF THERE IS A BASIS OF C MULTINOMIALS, ALL OF DEGREE .LE. DEGREE , OF CARDINALITY C NPTS C NPOLYS - (PASSED/RETURNED) C IGNORED IF DEGREE .GE. 0. C IF DEGREE .LT. 0 THEN THE VALUE OF NPOLYS WILL BE TAKEN AS C THE SIZE OF THE BASIS OF MULTINOMIALS TO BE USED IN THE FIT. C NPOLYS MUST SATISFY NPOLYS .LT. NPTS AND NPOLYS .GE. 1 C NPTS --- (PASSED) C THE NUMBER OF DATA POINTS TO BE USED IN THE FIT. C NPTS MUST BE .GE. 1. C DIMEN -- (PASSED) C THE NUMBER OF VARIABLES. C IWORK -- (RETURNED) C AN INTEGER WORK ARRAY OF LENGTH AT LEAST C IF DEGREE .GE. 0 THEN C 4*BINOMIAL( DIMEN + DEGREE , DIMEN ) C +( DIMEN )*( DEGREE ) C ELSE C 4*BINOMIAL( DIMEN +D,D)+( DIMEN )*D C WHERE D IS THE MINIMUM CARDINALITY OF A BASIS OF DEGREE C DEGREE SUCH THAT C BINOMIAL( DIMEN +ABS( DEGREE ), DIMEN ) .GE. NPOLYS C IWKLEN - (PASSED) C THE LENGTH OF IWORK C IREQD -- (RETURNED) C THE SIZE OF THE INTEGER WORK ARRAY REQUIRED BY MFIT FOR C THE FIT SPECIFIED BY THE 4 INPUT PARAMETERS. C DREQD -- (RETURNED) C THE SIZE OF THE DOUBLE PRECISION WORK ARRAY REQUIRED BY C MFIT FOR THE FIT SPECIFIED BY THE 4 INPUT PARAMETERS. C ERROR -- (RETURNED) C 0 IF NPOLYS , DIMEN , DEGREE , NPTS AND IWKLEN ARE C VALID AND CONSISTENT WITH EACH OTHER. C 1 IF DEGREE .GE. 0 BUT THERE IS AN INTERPOLATING MULTINOMIAL C OF SMALLER DEGREE OR IF DEGREE .LT. 0 AND NPOLYS .GT. NPTS C 2 IF DEGREE .LT. 0 AND NPOLYS .LE. 0 C 3 IF NPTS .LT. 1 AND/OR DIMEN .LT. 1 C 4 IF IWKLEN IS TOO SMALL (SET IWKLEN TO THE VALUE RETURNED C IN IREQD TO RESOLVE THIS PROBLEM) C C NOTE THAT DEGREE , NPOLYS , PSIWID AND ALFL ARE RETURNED C IN IWORK (1-4), RESPECTIVELY. C C DATE LAST MODIFIED C ---- ---- -------- C DECEMBER 10, 1984 C **************** C C *************** C BASIZ COMPUTES THE SIZE OF THE BASIS (AND AUXILIARY SIZES) C BASED PRIMARILY UPON THE DEGREE, NUMBER OF FITTING POINTS, C AND THE DIMENSION. C *************** C CALL BASIZ(DEGREE,NPTS,DIMEN,NPOLYS,ERROR) IF ( ERROR .GE. 2 ) RETURN IREQD = 4 * NPOLYS + DEGREE * DIMEN IF ( IWKLEN .GE. IREQD ) GO TO 5 ERROR = 4 RETURN 5 NEWSTT = 4 * NPOLYS + 1 C C *************** C SET UP USEFUL INDEXING ARRAYS C IWORK(1) ,..., IWORK(NEWSTT-1) C AND C IWORK(NEWSTT ,..., IWORK(NEWSTT+DIMEN*DEGREE) C *************** C CALL MTABLE(DEGREE,DIMEN,NPOLYS,IWORK,IWORK(NEWSTT),ALFL) IWORK(1) = DEGREE IWORK(2) = NPOLYS C C *************** C FORCE ALFL TO BE AT LEAST 1 SO THAT DIMENSION STATEMENTS C USING ALFL DO NOT BOMB. C *************** C IF ( ALFL .GT. 1 ) ALFL = ALFL - 1 IWORK(4) = ALFL C C *************** C THE FOLLOWING IS A SECTION OF CODE FOR SETTING UP THE C STORAGE MANAGEMENT OF THE PSI ARRAY. THERE IS A C COMPLICATED DOVETAILING FORMULA USED TO PACK INFORMATION C INTO PSI WITHOUT LEAVING GAPS. C C ARRAY LENGTH C ----- ------ C MAXABS DIMEN + 1 C ALPHA ALFL C C NPOLYS C SUMSQS NPOLYS C C THE NUMBER OF COLUMNS IN PSI , PSIWID , IS DETERMINED BY C PSIWID = NPOLYS + 1 - (THE SMALLEST M SUCH THAT ALPHA(J,M) C IS NONZERO AND J .GE. NPOLYS) C THIS INSURES THAT IF THE USER EXTENDS THE BASIS, ALL THE PSI C REQUIRED WILL CERTAINLY BE STORED C C IF DEGREE( NPOLYS ) .LE. 2 THEN (CASE 1) C PSIWID = NPOLYS C ELSE C IF K = DIMEN THEN (CASE 2) C PSIWID = NPOLYS C - NEWKJ( 1 , DEGREE(NPOLYS)-1 ) + 1 C ELSE C PSIWID = NPOLYS C + 1 C - ( C THE SMALLER OF C NEWKJ(K+1,DEGREE(NPOLYS)-2) (CASE 3) C AND C INDEXS(3,NPOLYS) (CASE 4) C ) C IF ( DEGREE .GT. 2 ) GO TO 10 C C *************** C CASE 1 C *************** C PSIWID = NPOLYS GO TO 40 10 NPLYT4 = 4 * NPOLYS C C *************** C KMXBAS IS K C NPOLYS C *************** C KMXBAS = IWORK(NPLYT4 - 2) C IF ( KMXBAS .NE. DIMEN ) GO TO 20 C C *************** C CASE 2 C *************** C PSIWID = NPOLYS - IWORK(4 * NPOLYS - 1) GO TO 40 C C *************** C INDEX = NEWKJ( K + 1 , DEGREE(NPOLYS-2) ) C NPOLYS C *************** C 20 INDEX = NPLYT4 + (DEGREE - 3) * DIMEN + KMXBAS + 1 KJP1D2 = IWORK(INDEX) C C *************** C STARTJ = INDEXS(3,NPOLYS) C *************** C STARTJ = IWORK(NPLYT4 - 1) IF ( STARTJ .GT. KJP1D2 ) GO TO 30 C C *************** C CASE 4 C *************** C PSIWID = NPOLYS - STARTJ + 1 GO TO 40 C C *************** C CASE 3 C *************** C 30 PSIWID = NPOLYS - KJP1D2 + 1 40 IWORK(3) = PSIWID DREQD = 2 * NPOLYS + DIMEN + 1 + NPTS * PSIWID + ALFL RETURN END SUBROUTINE BASIZ(DEGREE,NPTS,DIMEN,NPOLYS,ERROR) C INTEGER TOP,BOT,DEGREE,NPTS,DIMEN,NPOLYS,ERROR,I,ROWLEN C C *************** C PURPOSE C ------- C C IF DEGREE .GE. 0 THEN C FIND THE SIZE OF A BASIS REQUIRED EITHER TO C 1) APPROXIMATE THE DATA WITH A POLYNOMIAL OF DEGREE C GIVEN BY THE PARAMETER DEGREE C OR TO C 2) SPAN THE SPACE OF POLYNOMIALS OF DEGREE .LE. THE C SMALLEST DEGREE OF POLYNOMIAL WHICH INTERPOLATES THE C DATA. C IN CASE 1 ERROR = 0. C IN CASE 2 ERROR = 1. C ELSE C IF NPOLYS .GE. 1 THEN C IF NPOLYS .GT. NPTS THEN C SET NPOLYS = NPTS , FIND THE SMALLEST DEGREE OF A C POLYNOMIAL WHICH INTERPOLATES THE DATA, AND SET C ERROR = 1. C ELSE C FIND THE LARGEST DEGREE DEGREE OF A POLYNOMIAL IN C A BASIS OF NPOLYS POLYNOMIALS GENERATED ACCORDING C TO OUR ORDERING AND SET ERROR = 0. C ELSE C ERROR = 2 C C THIS SUBROUTINE IS CALLED BY ALLOT . IT IS NOT CALLED BY C THE USER DIRECTLY. C C DATE LAST MODIFIED C ---- ---- -------- C OCTOBER 16, 1984 C **************** C ERROR = 0 IF ( NPTS .GE. 1 .AND. DIMEN .GE. 1 ) GO TO 10 ERROR = 3 RETURN C 10 CONTINUE IF ( DEGREE .LT. 0 ) GO TO 30 C ROWLEN = 1 NPOLYS = 1 TOP = DIMEN - 1 BOT = 0 IF ( DEGREE .LT. 1 ) GO TO 30 DO 20 I=1,DEGREE TOP = TOP + 1 BOT = BOT + 1 ROWLEN = (ROWLEN*TOP)/BOT NPOLYS = NPOLYS + ROWLEN 20 CONTINUE C 30 CONTINUE IF ( NPOLYS .GE. 1 ) GO TO 40 ERROR = 2 RETURN 40 CONTINUE IF ( NPOLYS .LT. NPTS ) GO TO 50 NPOLYS = NPTS ERROR = 1 50 CONTINUE ROWLEN = 1 I = 1 DEGREE = 0 TOP = DIMEN - 1 BOT = 0 60 CONTINUE IF ( I .GE. NPOLYS ) GO TO 70 TOP = TOP + 1 BOT = BOT + 1 ROWLEN = (ROWLEN*TOP)/BOT I = I + ROWLEN DEGREE = DEGREE + 1 IF ( I .LT. NPOLYS ) GO TO 60 70 CONTINUE RETURN END SUBROUTINE MTABLE(DEGREE,DIMEN,NPOLYS,INDEXS,NEWKJ,ALFLP1) C INTEGER J,KJ,CURDEG,JPRIME,NWITHK,I,CURM1,RALEN,DIMM1,DIMM2 INTEGER NPOLYS,DIMEN,DEGREE,ALFLP1,DIMP1 INTEGER INDEXS(4,NPOLYS),NEWKJ(DIMEN,DEGREE) C C *************** C PURPOSE C ------- C C TABULATE JP AND KJ FOR EACH J C C VARIABLES C --------- C C ALFLP1 -- (INTEGER) -- (PASSED) C THE LENGTH REQUIRED FOR ARRAY ALPHA , PLUS ONE C DEGREE -- (INTEGER) -- (PASSED) C THE DEGREE OF THE POLYNOMIAL TO BE FITTED C DIMEN -- (INTEGER) -- (PASSED) C NUMBER OF INDEPENDENT VARIABLES C INDEXS -- (INTEGER, 2-SUBSCRIPT ARRAY) -- (RETURNED) C INDEXS (1, J ) IS JP , INDEXS (2, J ) IS KJ , C INDEXS (3, J ) IS THE FIRST NONZERO RECURRENCE COEFFICIENT C IN ALPHA AND INDEXS (4, J ) IS ITS LOCATION IN ALPHA . C NEWKJ -- (INTEGER, 2-SUBSCRIPT ARRAY) -- (RETURNED) C NEWKJ ( K , D ) IS THE FIRST MONOMIAL OF DEGREE D HAVING C KJ = K . C NPOLYS -- (INTEGER) -- (PASSED) C NUMBER OF MONOMIALS OF DEGREE .LE. ORDER IN DIMEN C INDEPENDENT VARIABLES. C C THIS SUBPROGRAM CAN BE CODED (EXCLUDING THE PART FOR CALCULATING C INDEXS (3, J ) AND INDEXS (4, J )) MENTALLY MORE EFFICIENTLY C BUT COMPUTATIONALLY LESS EFFICIENTLY AS C C J = 2 C DO 5 KJ = 1,DIMEN C NEWKJ(KJ,1) = KJ + 1 C INDEXS(1,J) = 1 C INDEXS(2,J) = KJ C J = J + 1 C 5 CONTINUE C DO 10 CURDEG = 2,DEGREE C DO 10 KJ = 1,DIMEN C JPRIME = NEWKJ(KJ,CURDEG - 1) C NEWKJ(KJ,CURDEG) = J C NWITHK = COMB(DIMEN + CURDEG - KJ - 1,CURDEG - 1) C DO 10 I = 1,NWITHK C INDEXS(1,J) = JPRIME C INDEXS(2,J) = KJ C JPRIME = JPRIME + 1 C J = J + 1 C 10 CONTINUE C C WHERE COMB(N,KJ) IS N-FACTORIAL / ((N-KJ)-FACTORIAL * KJ-FACTORIAL C HERE WE MAKE USE OF THE RECURRENCE RELATIONS C C COMB(DIMEN+CURDEG-2,CURDEG-1) C C (DIMEN+CURDEG-2)*COMB(DIMEN+CURDEG-3,CURDEG-2) C = ---------------------------------------------- C (CURDEG-1) C C AND C C COMB(DIMEN+CURDEG-KJ-1,CURDEG-1) C C (DIMEN-KJ+1)*COMB(DIMEN+CURDEG-KJ,CURDEG-1) C = ------------------------------------------- C (DIMEN+CURDEG-KJ) C C C DATE LAST MODIFIED C ---- ---- -------- C OCTOBER 16, 1984 C **************** C ALFLP1 = 1 C C *************** C SET INDEXS (4,1) TO 1 SO THAT ALFL - INDEXS (4,1)+1 IS THE C NUMBER OF COLUMNS REQUIRED FOR PSI FOR NPOLYS =1 ( ALFL C IS DEFINED IN THE MAINLINE TO BE ALFLP1 -1 IF ALFLP1 .GT. 1 C AND ALFLP1 OTHERWISE. C *************** C INDEXS(4,1) = 1 C IF ( NPOLYS .EQ. 1 ) RETURN J = 2 DO 10 KJ = 1,DIMEN NEWKJ(KJ,1) = KJ + 1 INDEXS(1,J) = 1 INDEXS(2,J) = KJ INDEXS(3,J) = 1 INDEXS(4,J) = ALFLP1 ALFLP1 = ALFLP1 + J - 1 IF ( J .EQ. NPOLYS ) RETURN 10 J = J + 1 IF ( DEGREE .EQ. 1 ) RETURN RALEN = 1 DIMM1 = DIMEN - 1 DIMM2 = DIMEN - 2 DIMP1 = DIMEN + 1 DO 70 CURDEG = 2,DEGREE CURM1 = CURDEG - 1 RALEN = (RALEN * (DIMM2 + CURDEG)) / CURM1 NWITHK = RALEN KJ = 1 20 JPRIME = NEWKJ(KJ,CURM1) NEWKJ(KJ,CURDEG) = J IF ( KJ .EQ. DIMEN ) GO TO 60 DO 50 I = 1,NWITHK INDEXS(1,J) = JPRIME INDEXS(2,J) = KJ C C *************** C CALCULATE INDEXS (3, J ), INDEXS (4, J ) C *************** C IF ( KJ .LT. INDEXS(2,JPRIME) ) GO TO 30 INDEXS(3,J) = INDEXS(1,JPRIME) GO TO 40 30 INDEXS(3,J) = NEWKJ(1,CURDEG - 1) 40 INDEXS(4,J) = ALFLP1 ALFLP1 = ALFLP1 + J - INDEXS(3,J) IF ( J .EQ. NPOLYS ) RETURN C JPRIME = JPRIME + 1 50 J = J + 1 KJ = KJ + 1 NWITHK = (NWITHK * (DIMP1 - KJ)) / (DIMEN + CURDEG - KJ) GO TO 20 60 INDEXS(1,J) = JPRIME INDEXS(2,J) = DIMEN INDEXS(3,J) = INDEXS(1,JPRIME) INDEXS(4,J) = ALFLP1 ALFLP1 = ALFLP1 + J - INDEXS(3,J) IF ( J .EQ. NPOLYS ) RETURN 70 J = J + 1 RETURN END SUBROUTINE GNRTP(DEGREE,ALPHA,PSI,INDEXS, + NEWKJ,SUMSQS,COORD,NCROWS,NPOLYS, + DIMEN,NPTS,F,Z,C,PSIWID,WEIGHT, + ALFL,DIMP1,MAXABS,ERROR) C INTEGER DEGREE,DIMEN,NPOLYS,NPTS,K,PSIWID,ALFL,P,STTDEG,ONPLYS INTEGER ERROR,DIMP1 INTEGER INDEXS(4,NPOLYS),NEWKJ(DIMEN,DEGREE) REAL PSI(NPTS,PSIWID),ALPHA(ALFL),F(NPTS) REAL COORD(NCROWS,DIMEN),MAXABS(DIMP1),WEIGHT(NPTS) REAL Z(NPTS),SUMSQS(NPOLYS),C(NPOLYS) REAL RUNTOT,RNTOT1 C C *************** C PURPOSE C ------- C C THE MULTINOMIAL FIT IS GENERATED INCREMENTALLY, A BASIS ELEMENT C AT A TIME. THIS SUBROUTINE STARTS THE PROCESS OFF BY SETTING UP C THE FIRST BASIS ELEMENT, SCALING THE DATA, FINDING THE FIRST C COEFFICIENT, AND INITIALIZING THE WORK ARRAY Z. GNRTP THEN C CALLS INCDG IF MORE THAN ONE BASIS ELEMENT IS REQUIRED. C C THIS SUBROUTINE IS CALLED BY MFIT . IT IS NOT CALLED BY THE C USER. C C THIS SUBROUTINE CALLS SCALPM , SCALDN , AND INCDG . C C C MODIFIED BY A.H. MORRIS (NSWC) C **************** C C *************** C SET UP THE SCALING. C *************** C DO 10 K = 1,DIMEN CALL SCALPM(COORD(1,K),NPTS,MAXABS(K)) 10 CALL SCALDN(COORD(1,K),NPTS,MAXABS(K)) CALL SCALPM(F,NPTS,MAXABS(DIMP1)) CALL SCALDN(F,NPTS,MAXABS(DIMP1)) C C *************** C SUMSQS (1) = (1,1) C C = (F,1) / (1,1) C 1 C *************** C RUNTOT = 0.0 RNTOT1 = 0.0 DO 20 P = 1,NPTS PSI(P,1) = 1.0 RNTOT1 = RNTOT1 + WEIGHT(P) 20 RUNTOT = RUNTOT + F(P) * WEIGHT(P) SUMSQS(1) = RNTOT1 C(1) = RUNTOT / RNTOT1 C C *************** C Z = F - C C 1 C *************** C DO 30 P = 1,NPTS 30 Z(P) = F(P) - C(1) C IF ( NPOLYS .EQ. 1 ) RETURN STTDEG = 1 ONPLYS = 1 C CALL INCDG(DEGREE,ALPHA,PSI,INDEXS,NEWKJ,SUMSQS, + COORD,NCROWS,NPOLYS,DIMEN,NPTS,F,Z,C,PSIWID, + WEIGHT,ALFL,ONPLYS,STTDEG,ERROR) RETURN END SUBROUTINE INCDG(DEGREE,ALPHA,PSI,INDEXS,NEWKJ, + SUMSQS,COORD,NCROWS,NPOLYS, + DIMEN,NPTS,F,Z,C,PSIWID,WEIGHT, + ALFL,ONPLYS,STTDEG,ERROR) C INTEGER JPRIME,P,J,CURDEG,KJ,KJP,L,JPM1,JM1 INTEGER M,START,JINDEX,JPINDX,Q,J3,J1,J1MJ2,ERROR INTEGER J0MJ1,J1M1,STARTA,ONPLYS,ONPP1,STTDEG,INDEX1,INDEX2 INTEGER DEGREE,NPOLYS,NPTS,DIMEN,PSIWID,ALFL INTEGER INDEXS(4,NPOLYS),NEWKJ(DIMEN,DEGREE) REAL ALPHA(ALFL),COORD(NCROWS,DIMEN),PSI(NPTS,PSIWID) REAL SUMSQS(NPOLYS),C(NPOLYS),F(NPTS),WEIGHT(NPTS) REAL Z(NPTS) REAL ARC,RUNTOT,RNTOT1,RNTOT2 C C *************** C PURPOSE C ------- C C THE MULTINOMIAL FIT IS GENERATED INCREMENTALLY, A BASIS ELEMENT C AT A TIME. THIS SUBROUTINE CONTINUES THE PROCESS STARTED OFF BY C GNRTP . C C THIS SUBROUTINE IS CALLED BY GNRTP AND NOT BY THE USER. C C C MODIFIED BY A.H. MORRIS (NSWC) C C **************** C IF ( ONPLYS .GE. 1 .AND. STTDEG .GE. 1 ) GO TO 10 ERROR = 6 RETURN 10 IF ( INDEXS(2,ONPLYS) .EQ. DIMEN ) GO TO 20 CURDEG = STTDEG GO TO 30 20 CURDEG = STTDEG + 1 30 ONPP1 = ONPLYS + 1 DO 170 J = ONPP1,NPOLYS JPRIME = INDEXS(1,J) JINDEX = J - ((J - 1) / PSIWID) * PSIWID JPINDX = JPRIME - ((JPRIME - 1) / PSIWID) * PSIWID KJ = INDEXS(2,J) START = INDEXS(3,J) M = START STARTA = INDEXS(4,J) - START IF ( CURDEG .EQ. 1 ) GO TO 100 KJP = INDEXS(2,JPRIME) J1 = NEWKJ(KJ,CURDEG - 1) C C *************** C CALCULATE THOSE ALPHA ( J , M ) THAT CAN BE CALCULATED FROM C PREVIOUSLY CALCULATED ALPHAS. C *************** C IF ( KJ .LT. KJP ) GO TO 50 C C *************** C FIRST CALCULATE THOSE BETWEEN JPP AND THE END OF 2 ROWS BACK. C CALCULATE ALPHA ( J , JPP ) C *************** C INDEX1 = INDEXS(4,J) ALPHA(INDEX1) = SUMSQS(JPRIME) / SUMSQS(START) C M = START + 1 J3 = NEWKJ(1,CURDEG - 1) - 1 IF ( M .GT. J3 ) GO TO 50 C C *************** C CURDEG .GT. 2 IF CONTROL HAS PASSED THE BRANCHES IN THE 3-RD C PREVIOUS AND 8-TH PREVIOUS STATEMENTS. C *************** C J1MJ2 = J1 - NEWKJ(KJ,CURDEG - 2) C DO 40 L = M,J3 Q = J1MJ2 + L INDEX1 = STARTA + L INDEX2 = INDEXS(4,Q) - INDEXS(3,Q) + JPRIME 40 ALPHA(INDEX1) = ALPHA(INDEX2) * SUMSQS(JPRIME) / + SUMSQS(L) C C *************** C CALCULATE ALPHA ( J , M ) FOR M BETWEEN THE 2 C RANGES CALCULATED BEFORE USING C C ALPHA ( J , L ) = (X * PSI ,PSI ) / (PSI ,PSI ) C K JP L L L C J C *************** C M = J3 + 1 50 IF ( JPRIME .EQ. J1 ) GO TO 100 IF ( KJ .EQ. 1 ) GO TO 80 J1M1 = J1 - 1 DO 70 L = M,J1M1 RUNTOT = 0.0 DO 60 P = 1,NPTS INDEX1 = L - ((L - 1) / PSIWID) * PSIWID 60 RUNTOT = RUNTOT + COORD(P,KJ) * PSI(P,JPINDX) * + PSI(P,INDEX1) * WEIGHT(P) INDEX1 = STARTA + L 70 ALPHA(INDEX1) = RUNTOT / SUMSQS(L) C C *************** C CALCULATE ALPHA ( J , M ) FOR M BETWEEN C NEWKJ ( KJ , CURDEG - 1) AND C JP - 1. C *************** C 80 J0MJ1 = NEWKJ(KJ,CURDEG) - J1 JPM1 = JPRIME - 1 DO 90 L = J1,JPM1 Q = J0MJ1 + L INDEX1 = STARTA + L INDEX2 = INDEXS(4,Q) - INDEXS(3,Q) + JPRIME 90 ALPHA(INDEX1) = ALPHA(INDEX2) * SUMSQS(JPRIME) / + SUMSQS(L) M = JPRIME C C *************** C CALCULATE THE REMAINING ALPHA ( J , M ) FROM C C ALPHA ( J , L ) = (X * PSI ,PSI ) / (PSI ,PSI ) C K JP L L L C J C *************** C 100 JM1 = J - 1 DO 120 L = M,JM1 RUNTOT = 0.0 DO 110 P = 1,NPTS INDEX1 = L - ((L - 1) / PSIWID) * PSIWID 110 RUNTOT = RUNTOT + COORD(P,KJ) * PSI(P,JPINDX) * + PSI(P,INDEX1) * WEIGHT(P) INDEX1 = STARTA + L 120 ALPHA(INDEX1) = RUNTOT / SUMSQS(L) C C *************** C NOW CALCULATE THE PSI (P,J), SUMSQS (J) AND C (J) USING C C J-1 C PSI = X * PSI - SUM ALPHA(J,L) * PSI C J K JP L=JPP L C C SUMSQS = (PSI ,PSI ) C J J J C C C = (Z,PSI ) C J J C *************** C 130 JM1 = J - 1 ARC = 0.0 RNTOT1 = 0.0 RNTOT2 = 0.0 DO 150 P = 1,NPTS RUNTOT = COORD(P,KJ) * PSI(P,JPINDX) DO 140 L = START,JM1 INDEX1 = STARTA + L INDEX2 = L - ((L - 1) / PSIWID) * PSIWID 140 RUNTOT = RUNTOT - ALPHA(INDEX1) * PSI(P,INDEX2) PSI(P,JINDEX) = RUNTOT ARC = ARC + PSI(P,INDEX2) * PSI(P,JINDEX) * + WEIGHT(P) RNTOT1 = RNTOT1 + PSI(P,JINDEX) * PSI(P,JINDEX) * + WEIGHT(P) 150 RNTOT2 = RNTOT2 + Z(P) * PSI(P,JINDEX) * WEIGHT(P) IF (ARC * ARC .GE. SUMSQS(JM1) * RNTOT1 * 1.E-03) + GO TO 200 SUMSQS(J) = RNTOT1 C(J) = RNTOT2 / RNTOT1 C C *************** C CALCULATE THE NEW Z ( P ) AND THE NEW SSRES USING C C Z = Z - C * PSI C J J C *************** C DO 160 P = 1,NPTS 160 Z(P) = Z(P) - C(J) * PSI(P,JINDEX) STTDEG = CURDEG 170 IF ( KJ .EQ. DIMEN ) CURDEG = CURDEG + 1 RETURN C C *************** C THE J-TH BASIS MULTINOMIAL CANNOT BE COMPUTED ACCURATELY. C ONLY J - 1 BASIS MULTINOMIALS ARE GENERATED. C *************** C 200 ERROR = -1 DEGREE = STTDEG NPOLYS = JM1 RETURN END SUBROUTINE SCALPM(COORD,NPTS,MAXABS) C INTEGER NPTS,P REAL MAXABS,A REAL COORD(NPTS) C C *************** C PURPOSE C ------- C C FIND SCALING PARAMETER(S) FOR THE PROBLEM. IF THE SCALING SCHEME C IS CHANGED, ALL FOUR OF THE FOLLOWING WOULD HAVE TO BE CHANGED C C 1) SCALPM - FIND THE SCALING PARAMETERS C 2) SCALDN - SCALE THE PROBLEM DATA C 3) THE SCALING OF THE RESIDUALS IN MFIT C 4) THE SCALING PERFORMED IN MEVAL1 C C THIS SUBROUTINE IS CALLED BY GNRTP . IT IS NOT CALLED BY THE C USER. C C THE SCALING WHICH IT DEFINES MUST BE COORDINATED WITH THE C SCALING OF RESIDUALS WHICH IS CARRIED OUT TOWARD THE END OF THE C SUBROUTINE MFIT. THE SCALING MUST ALSO BE COORDINATED WITH THE C SCALING PERFORMED IN THE 10 LOOP AND AT STATEMENTS 40 AND 50 C (WITH THE SCALE FACTOR MAXABS(DIMP1)) IN MEVAL1. C C **************** C MAXABS = 0.0 DO 10 P = 1,NPTS A = ABS(COORD(P)) 10 IF ( A .GT. MAXABS ) MAXABS = A RETURN END SUBROUTINE SCALDN(COORD,NPTS,MAXABS) C INTEGER NPTS,P REAL MAXABS REAL COORD(NPTS) C C *************** C PURPOSE C ------- C C CARRY OUT THE DATA-SCALING WHICH IS DEFINED BY THE SUBROUTINE C SCALPM . C C THIS SUBROUTINE IS CALLED BY GNRTP . IT IS NOT CALLED BY THE C USER. C C THE SCALING WHICH THIS ROUTINE CARRIES OUT MUST BE CONSISTENT C WITH THE SCALING IN THE SUBROUTINES MFIT AND MEVAL1. C C **************** C IF ( MAXABS .EQ. 0.0E+00 ) RETURN DO 10 P = 1,NPTS 10 COORD(P) = COORD(P) / MAXABS RETURN END SUBROUTINE MEVAL(DIMEN,EVLDEG,NEPOLS,NEPTS,EVLCDS,NEROWS,EVLVLS, + ERROR,FITIWK,FITDWK,FIWKLN,FDWKLN,TEMP) C INTEGER FIWKLN,FDWKLN,NEPOLS,NEPTS,DIMEN,ERROR,MAXSTT,ALFSTT,CSTT INTEGER GBASIZ,ALFL,DIMP1,EVLDEG,TOP,BOT,CURDEG,PSISTT INTEGER FITIWK(FIWKLN) REAL FITDWK(FDWKLN),EVLCDS(NEROWS,DIMEN) REAL EVLVLS(NEPTS),TEMP(DIMEN) C C *************** C PURPOSE C ------- C C THIS SUBROUTINE EVALUATES THE LEAST-SQUARES MULTINOMIAL FIT C WHICH HAS BEEN PREVIOUSLY PRODUCED BY MFIT . EITHER THE FULL C MULTINOMIAL AS PRODUCED MAY BE EVALUATED, OR ONLY AN INITIAL C SEGMENT THEREOF. AS IN THE CASE WITH MFIT , IT IS POSSIBLE C (1) TO SPECIFY MULTINOMIALS OF A FULL GIVEN DEGREE, OR C (2) TO SPECIFY THE NUMBER OF ORTHOGONAL BASIS ELEMENTS TO C ACHIEVE A PARTIAL-DEGREE FIT. C C IN CASE (1), THE DESIRED DEGREE IS GIVEN AS THE VALUE OF C EVLDEG (WHICH MUST BE NONNEGATIVE AND NOT GREATER THAN THE C VALUE USED FOR FITDEG IN MFIT ), AND THE PARAMETER NEPOLS C WILL BE SET BY MEVAL TO SPECIFY THE NUMBER OF BASIS ELEMENTS C REQUIRED. IF EVLDEG .LT. FITDEG IS GIVEN, THEN ONLY THE C INITIAL PORTION OF THE FITTING MULTINOMIAL (OF DEGREE EVLDEG ) C WILL BE EVALUATED. C C IN CASE (2), EVLDEG IS TO BE SET NEGATIVE, IN WHICH CASE THE C VALUE OF NEPOLS (WHICH MUST BE POSITIVE AND NOT GREATER THAN C THE VALUE USED FOR NFPOLS IN MFIT ) WILL BE TAKEN AS C DEFINING THE INITIAL PORTION OF THE FITTING MULTINOMIAL TO BE C EVALUATED. C C IF NEPOLS = NFPOLS (WITH EVLDEG .LT. 0), OR EVLDEG = C FITDEG (WITH EVLDEG .GT. 0), THEN THE FULL MULTINOMIAL C GENERATED BY MFIT WILL BE EVALUATED. C C THE EVALUATION WILL TAKE PLACE FOR EACH OF THE POINTS C (COLLECTION OF VARIABLE VALUES) GIVEN AS A ROW OF THE MATRIX C EVLCDS . THE VALUES PRODUCED FROM THE FULL, OR PARTIAL, C MULTINOMIAL WILL BE PLACED IN THE ARRAY EVLVLS . C C VARIABLES C --------- C C DIMEN -- (INTEGER) -- (PASSED) C THE NUMBER OF VARIABLES. C EVLDEG -- (INTEGER) -- (PASSED) C IF EVLDEG .LT. 0, THEN THIS PARAMETER WILL BE IGNORED. C IF EVLDEG .GE. 0, THEN THE VALUE OF EVLDEG MUST SATISFY C EVLDEG .LE. (THE DEGREE OF THE APPROXIMATING MULTINOMIAL C GENERATED IN MFIT ). IN THIS CASE EVLDEG WILL SPECIFY C THE DEGREE OF THE INITIAL PORTION OF THE FITTING MULTINOMIAL C TO BE EVALUATED. C NEPOLS -- (INTEGER) -- (PASSED/RETURNED) C IF EVLDEG .GE. 0, THEN THIS PARAMETER WILL BE IGNORED. C IF EVLDEG .LT. 0, THEN THE PARTIAL MULTINOMIAL INVOLVING THE C FIRST NEPOLS ORTHOGONAL BASIS FUNCTIONS WILL BE EVALUATED C AT THE POINTS GIVEN BY EVLCDS . THE RESULTING VALUES WILL C BE STORED IN EVLVLS . C THE VALUE OF NEPOLS MUST BE .GE. 1 AND .LE. (THE SIZE OF THE C BASIS GENERATED IN MFIT ), WHICH WAS RETURNED AS THE C VALUE OF NFPOLS . C NEPOLS WILL BE CHANGED IF EVLDEG .GT. 0 TO GIVE THE SIZE OF C BASIS REQUIRED FOR THE MULTINOMIAL OF DEGREE EVLDEG . C NEPTS -- (INTEGER) -- (PASSED) C THE NUMBER OF EVALUATION POINTS. C EVLCDS -- (REAL 2-SUBSCRIPT ARRAY) -- (PASSED) C EVLCDS (P,K) IS THE VALUE OF THE K-TH VARIABLE AT THE P-TH C EVALUATION POINT. C NEROWS -- (INTEGER) -- (PASSED) C THE ROW DIMENSION DECLARED FOR EVLCDS IN THE CALLING PROGRAM. C EVLVLS -- (INTEGER) -- (RETURNED) C EVLVLS (P) IS THE VALUE OF THE EVALUATED MULTINOMIAL AT THE C P-TH EVALUATION POINT. C ERROR -- (INTEGER) -- (RETURNED) C 0 ......... IF NO ERRORS C -1 ......... IF NEPOLS .GT. NFPOLS OR NEPOLS .LT. 1 C -2 ......... IF NEPTS .LT. 1 OR DIMEN .LT. 1 C FITIWK -- (INTEGER, 1-SUBSCRIPT ARRAY) -- (PASSED) C THE INTEGER WORK ARRAY OF LENGTH FIWKLN THAT WAS USED IN C MFIT . C FITDWK -- (REAL 2-SUBSCRIPT ARRAY) -- (PASSED) C THE REAL WORK ARRAY OF LENGTH FDWKLN THAT WAS C USED IN MFIT . C FIWKLN -- (INTEGER) -- (PASSED) C THE LENGTH OF FITIWK . C FDWKLN -- (INTEGER) -- (PASSED) C THE LENGTH OF FITDWK . C TEMP -- (REAL 1-SUBSCRIPT ARRAY) C A WORK ARRAY OF LENGTH DIMEN (OR LONGER). C C THE SUBROUTINE MEVAL1 IS CALLED TO DO THE ACTUAL EVALUATION. C C MODIFIED BY A.H. MORRIS (NSWC) C C **************** C C C *************** C SET UP INDEX POINTERS TO THE BEGINNING OF EACH ROW OF C THE MTABLE -- THIS SETS THE BEGINNING POINT FOR EACH C FULL MULTINOMIAL DEGREE. C *************** C IF (NEPTS .LT. 1 .OR. DIMEN .LT. 1) GO TO 110 IF (EVLDEG) 40,10,20 C 10 NEPOLS = 1 GO TO 50 C 20 TOP = 1 BOT = 1 DO 30 CURDEG = 1,EVLDEG TOP = TOP * (DIMEN + CURDEG) 30 BOT = BOT * CURDEG NEPOLS = TOP / BOT C 40 GBASIZ = FITIWK(1) IF (NEPOLS .GT. GBASIZ .OR. NEPOLS .LT. 1) GO TO 100 C 50 ERROR = 0 DIMP1 = DIMEN + 1 ALFL = FITIWK(4) MAXSTT = 1 ALFSTT = DIMP1 + MAXSTT CSTT = ALFSTT + ALFL PSISTT = CSTT + FITIWK(2) C C *************** C THE ACTUAL EVALUATION IS DONE INSIDE MEVAL1. C *************** C CALL MEVAL1 (EVLCDS,NEROWS,FITDWK(CSTT),NEPTS,DIMEN,NEPOLS, + FITDWK(ALFSTT),FITIWK,FITDWK(PSISTT), + EVLVLS,ALFL,FITDWK(MAXSTT),TEMP,DIMP1) RETURN C C *************** C ERROR RETURN C *************** C 100 ERROR = -1 RETURN 110 ERROR = -2 RETURN END SUBROUTINE MEVAL1 (COORD,NCROWS,C,NEPTS,DIMEN,NPOLYS,ALPHA, + INDEXS,PSI,F,ALFL,MAXABS,X,DIMP1) C INTEGER DIMEN,NEPTS,NPOLYS,ALFL,DIMP1 INTEGER JM1,JPRIME,M,P,K,I,J,INDEX INTEGER INDEXS(4,NPOLYS) REAL ALPHA(ALFL),COORD(NCROWS,DIMEN),PSI(NPOLYS) REAL C(NPOLYS),F(NEPTS),MAXABS(DIMP1),X(DIMEN) REAL RUNTOT,RNTOT1 C C *************** C PURPOSE C ------- C C THIS SUBROUTINE PERFORMS THE MAIN WORK OF EVALUATING THE C FITTING MULTINOMIAL (OR THE INITIAL PORTION OF IT WHICH C IS REQUESTED BY THE SETTING OF NEPOLS , EVLDEG IN THE C CALL TO SUBROUTINE MEVAL . C C THIS SUBROUTINE IS CALLED BY MEVAL . IT IS NOT CALLED C DIRECTLY BY THE USER. C C THE BODY OF THIS SUBROUTINE FOLLOWS THE EXPLANATION C GIVEN IN C LEAST SQUARES FITTING USING C ORTHOGONAL MULTINOMIALS C BY C BARTELS AND JEZIORANSKI C IN C ACM TRANSACTIONS ON MATHEMATICAL SOFTWARE C C C MODIFIED BY A.H. MORRIS (NSWC) C C **************** C IF (NPOLYS .EQ. 1) GO TO 50 C PSI(1) = 1.0 DO 40 P = 1,NEPTS C C *************** C SCALE THE COORDINATES OF THE P-TH POINT C *************** C DO 10 K = 1,DIMEN X(K) = COORD(P,K) IF (MAXABS(K) .NE. 0.0) X(K) = X(K) / MAXABS(K) 10 CONTINUE C C *************** C USE THE BASIS FUNCTION COEFFICIENTS C AND RECURRENCE C COEFFICIENTS ALPHA TO EVALUATE THE FITTED MULTINOMIAL C AT THE P-TH POINT. C *************** C RNTOT1 = C(1) DO 30 J = 2,NPOLYS K = INDEXS(2,J) JPRIME = INDEXS(1,J) RUNTOT = X(K) * PSI(JPRIME) I = INDEXS(3,J) JM1 = J - 1 DO 20 M = I,JM1 INDEX = INDEXS(4,J) + M - I 20 RUNTOT = RUNTOT - PSI(M) * ALPHA(INDEX) PSI(J) = RUNTOT 30 RNTOT1 = RNTOT1 + C(J) * PSI(J) 40 F(P) = RNTOT1 * MAXABS(DIMP1) RETURN C C *************** C COMPUTE THE DEGREE 0 POLYNOMIAL C *************** C 50 RUNTOT = C(1) * MAXABS(DIMP1) DO 60 P = 1,NEPTS 60 F(P) = RUNTOT RETURN END SUBROUTINE DMFIT(DIMEN,FITDEG,NFPOLS,NFPTS, + FITCDS,NCROWS,FITVLS,WTS, + RESIDS,ERROR,FITIWK,FITDWK, + FIWKLN,FDWKLN,IREQD,DREQD) C INTEGER NFPOLS,FITDEG,NFPTS,DIMEN,FIWKLN,FDWKLN INTEGER ERROR,IREQD,DREQD,INDSTT,P,DIMP1,NCROWS INTEGER NEWSTT,MAXSTT,ALFSTT,PSISTT,CSTT,SSQSTT,PSIWID,ALFL INTEGER FITIWK(FIWKLN) DOUBLE PRECISION FITDWK(FDWKLN),FITCDS(NCROWS,DIMEN) DOUBLE PRECISION FITVLS(NFPTS),RESIDS(NFPTS) DOUBLE PRECISION WTS(NFPTS),SCALE C C *************** C PURPOSE C ------- C C THIS SUBROUTINE CONSTRUCTS A LEAST-SQUARES MULTINOMIAL FIT TO C GIVEN DATA USING A BASIS OF ORTHOGONAL MULTINOMIALS. THE COMPUTA- C TION IS PERFORMED IN DOUBLE PRECISION. C C THE DATA FOR THE FIT IS GIVEN IN THE ARRAYS FITCDS, FITVLS, AND C WTS. FITCDS IS A MATRIX, EACH ROW OF WHICH CONTAINS AN OBSERVA- C TION POINT. FITVLS IS A SINGLY-INDEXED ARRAY, EACH ELEMENT OF C WHICH CONTAINS A FUNCTION VALUE CORRESPONDING TO AN OBSERVATION C POINT. WTS IS A SINGLY-INDEXED ARRAY, EACH ELEMENT OF WHICH IS C A NONNEGATIVE WEIGHT FOR THE CORRESPONDING OBSERVATION. C C THE FIT WHICH IS PRODUCED IS A MULTINOMIAL EXPRESSED IN THE FORM C C C PSI (X ,...,X ) +...+ C PSI (X ,...,X ) C 1 1 1 DIMEN NFPOLS NFPOLS 1 DIMEN C C WHERE THE VALUE OF NFPOLS WILL BE AS GIVEN (IF FITDEG .LT. 0) C OR AS COMPUTED BY DMFIT TO GIVE A FULL-DEGREE FIT (IN CASE C FITDEG IS SPECIFIED .GE. 0). THE ELEMENTS C C PSI (X ,...,X ) C K 1 DIMEN C C FORM A BASIS FOR THE MULTINOMIALS WHICH IS ORTHOGONAL WITH C RESPECT TO THE WEIGHTS AND OBSERVATION POINTS. C C THE EXTENT OF THE FIT CAN BE SPECIFIED IN ONE OF TWO WAYS. C IF THE PARAMETER FITDEG IS SET .GE. 0, THEN A COMPLETE BASIS C FOR THE MULTINOMIALS OF DEGREE = FITDEG WILL BE USED. (AN C ERROR WILL BE FLAGGED IF THIS WILL REQUIRE MORE BASIS C MULTINOMIALS THAN THE NUMBER OF DATA POINTS WHICH WERE C GIVEN.) C IF THE PARAMETER FITDEG IS .LT. 0, THEN NFPOLS WILL BE C TAKEN AS THE COUNT OF THE NUMBER OF BASIS MULTINOMIALS TO BE C USED FOR A PARTIAL-DEGREE FIT. (AN ERROR WILL BE FLAGGED IF C NFPOLS .LT. 0.) C C VARIABLES C --------- C C DIMEN -- (INTEGER) -- (PASSED) C THE NUMBER OF VARIABLES. C FITDEG - (INTEGER) -- (PASSED/RETURNED) C IGNORED IF .LT. 0. C IF FITDEG .GE. 0 THEN FITDEG IS CHECKED AGAINST NFPTS . C THE VALUE OF FITDEG WILL BE REDUCED IF THERE IS A BASIS OF C MULTINOMIALS, ALL OF DEGREE .LE. FITDEG , OF CARDINALITY C NFPTS . SEE ERROR BELOW. C NFPOLS - (INTEGER) -- (PASSED/RETURNED) C IGNORED IF FITDEG .GE. 0. C IF FITDEG .LT. 0 THEN THE VALUE OF NFPOLS WILL BE TAKEN AS C THE SIZE OF THE BASIS OF MULTINOMIALS TO BE USED IN THE FIT. C NFPOLS MUST SATISFY NFPOLS .LT. NFPTS AND NFPOLS .GE. 1 C SEE ERROR BELOW. C NFPTS --- (INTEGER) -- (PASSED) C THE NUMBER OF DATA POINTS TO BE USED IN THE FIT. C NFPTS MUST BE .GE. 1. SEE ERROR BELOW. C FITCDS -- (DOUBLE PRECISION 2-SUBSCRIPT ARRAY) -- (PASSED) C FITCDS (P,K) IS THE VALUE OF THE K-TH VARIABLE AT THE P-TH C DATA POINT. C NCROWS -- (INTEGER) -- (PASSED) C THE ROW DIMENSION DECLARED FOR FITCDS IN THE CALLING C PROGRAM. C FITVLS -- (DOUBLE PRECISION 1-SUBSCRIPT ARRAY) -- (PASSED) C FITVLS (P) IS THE OBSERVED FUNCTION VALUE OF THE P-TH DATA C POINT. C WTS ----- (DOUBLE PRECISION 1-SUBSCRIPT ARRAY) -- (PASSED) C WTS (P) IS THE WEIGHT ATTACHED TO THE P-TH DATA POINT. C RESIDS -- (DOUBLE PRECISION 1-SUBSCRIPT ARRAY) -- (RETURNED) C RESIDS (P) IS THE DIFFERENCE BETWEEN THE FITTED FUNCTION AT C POINT P AND FITVLS (P). C ERROR -- (INTEGER) -- (RETURNED) C 0 THE DESIRED LEAST SQUARE MULTINOMIAL FIT WAS OBTAINED. C -1 ONLY THE FIRST NFPOLS BASIS POLYNOMIALS WERE OBTAINED. C FITDEG IS THE DEGREE OF THE FIT. C 1 IF FITDEG .GE. 0 BUT THERE IS AN INTERPOLATING MULTINOMIAL C OF SMALLER DEGREE OR IF FITDEG .LT. 0 AND NFPOLS .GT. NFPTS. C 2 IF FITDEG .LT. 0 AND NFPOLS .LE. 0. C 3 IF NFPTS .LT. 1 AND/OR DIMEN .LT. 1. C 4 IF IWKLEN AND/OR DWKLEN IS TOO SMALL. (SET IWKLEN TO C THE VALUE RETURNED IN IREQD , AND SET DWKLEN TO THE VALUE C RETURNED IN DREQD TO RESOLVE THIS PROBLEM.) C FITIWK -- (INTEGER, 1-SUBSCRIPT ARRAY) -- (RETURNED) C AN INTEGER WORK ARRAY OF LENGTH FIWKLN . UPON RETURN FROM C DMFIT, FITIWK CONTAINS DIMENSION AND ARRAY LENGTH INFORMATION. C FITDWK -- (DOUBLE PRECISION 1-SUBSCRIPT ARRAY) -- (RETURNED) C AN ARRAY OF LENGTH FDWKLN CONTAINING THE COEFFICIENTS C NEEDED FOR COMPUTING THE MULTINOMIAL FIT AT A POINT. C FIWKLN -- (INTEGER) -- (PASSED) C THE LENGTH OF THE ARRAY FITIWK . C FDWKLN -- (INTEGER) -- (PASSED) C THE LENGTH OF THE ARRAY FITDWK . C IREQD -- (INTEGER) -- (RETURNED) C THE LENGTH WHICH THE ARRAY FITIWK REALLY NEEDS TO BE. C DREQD -- (INTEGER) -- (RETURNED) C THE LENGTH WHICH THE ARRAY FITDWK REALLY NEEDS TO BE. C C C NOTE. THE 20 LOOP DEPENDS ON THE SCALING SCHEME BEING USED. THE C RESIDUAL SCALING MUST BE CONSISTENT WITH THAT DEFINED BY DSCALP C AND DSCALD. C C DMFIT CALLS ALLOT AND DGNRTP. C **************** C DIMP1 = DIMEN + 1 C C *************** C CALL ALLOT(FITDEG,NFPOLS,NFPTS,DIMEN,FITIWK,FIWKLN,IREQD,DREQD, + ERROR) IF ( ERROR .GE. 2 ) RETURN C IF ( FDWKLN .GE. DREQD ) GO TO 10 ERROR = 4 RETURN 10 CONTINUE C PSIWID = FITIWK(3) ALFL = FITIWK(4) INDSTT = 1 NEWSTT = 4 * NFPOLS + INDSTT MAXSTT = 1 ALFSTT = MAXSTT + DIMP1 CSTT = ALFSTT + ALFL SSQSTT = CSTT + NFPOLS PSISTT = SSQSTT + NFPOLS C C *************** C CALL DGNRTP(FITDEG,FITDWK(ALFSTT), + FITDWK(PSISTT),FITIWK(INDSTT), + FITIWK(NEWSTT),FITDWK(SSQSTT),FITCDS, + NCROWS,NFPOLS,DIMEN,NFPTS,FITVLS,RESIDS, + FITDWK(CSTT),PSIWID,WTS,ALFL,DIMP1, + FITDWK(MAXSTT),ERROR) C C *************** C STORE THE NUMBER OF BASIS POLYNOMIALS ACTUALLY COMPUTED C BY THE MODIFIED ROUTINE DINCDG CALLED BY DGNRTP. C *************** C FITIWK(1) = NFPOLS C C *************** C UNSCALE THE RESIDUALS FOR THE BENEFIT OF THE USER. C *************** C SCALE = FITDWK(DIMEN + 1) DO 20 P = 1,NFPTS RESIDS(P) = RESIDS(P) * SCALE 20 CONTINUE RETURN END SUBROUTINE DGNRTP(DEGREE,ALPHA,PSI,INDEXS, + NEWKJ,SUMSQS,COORD,NCROWS,NPOLYS, + DIMEN,NPTS,F,Z,C,PSIWID,WEIGHT, + ALFL,DIMP1,MAXABS,ERROR) C INTEGER DEGREE,DIMEN,NPOLYS,NPTS,K,PSIWID,ALFL,P,STTDEG,ONPLYS INTEGER ERROR,DIMP1 INTEGER INDEXS(4,NPOLYS),NEWKJ(DIMEN,DEGREE) DOUBLE PRECISION PSI(NPTS,PSIWID),ALPHA(ALFL),F(NPTS) DOUBLE PRECISION COORD(NCROWS,DIMEN),MAXABS(DIMP1),WEIGHT(NPTS) DOUBLE PRECISION Z(NPTS),SUMSQS(NPOLYS),C(NPOLYS) DOUBLE PRECISION RUNTOT,RNTOT1 C C *************** C PURPOSE C ------- C C THE MULTINOMIAL FIT IS GENERATED INCREMENTALLY, A BASIS ELEMENT C AT A TIME. THIS SUBROUTINE STARTS THE PROCESS OFF BY SETTING UP C THE FIRST BASIS ELEMENT, SCALING THE DATA, FINDING THE FIRST C COEFFICIENT, AND INITIALIZING THE WORK ARRAY Z. DGNRTP THEN C CALLS DINCDG IF MORE THAN ONE BASIS ELEMENT IS REQUIRED. C C THIS SUBROUTINE IS CALLED BY DMFIT . IT IS NOT CALLED BY THE C USER. C C THIS SUBROUTINE CALLS DSCALP , DSCALD , AND DINCDG . C C C MODIFIED BY A.H. MORRIS (NSWC) C **************** C C *************** C SET UP THE SCALING. C *************** C DO 10 K = 1,DIMEN CALL DSCALP(COORD(1,K),NPTS,MAXABS(K)) 10 CALL DSCALD(COORD(1,K),NPTS,MAXABS(K)) CALL DSCALP(F,NPTS,MAXABS(DIMP1)) CALL DSCALD(F,NPTS,MAXABS(DIMP1)) C C *************** C SUMSQS (1) = (1,1) C C = (F,1) / (1,1) C 1 C *************** C RUNTOT = 0.D0 RNTOT1 = 0.D0 DO 20 P = 1,NPTS PSI(P,1) = 1.D0 RNTOT1 = RNTOT1 + WEIGHT(P) 20 RUNTOT = RUNTOT + F(P) * WEIGHT(P) SUMSQS(1) = RNTOT1 C(1) = RUNTOT / RNTOT1 C C *************** C Z = F - C C 1 C *************** C DO 30 P = 1,NPTS 30 Z(P) = F(P) - C(1) C IF ( NPOLYS .EQ. 1 ) RETURN STTDEG = 1 ONPLYS = 1 C CALL DINCDG(DEGREE,ALPHA,PSI,INDEXS,NEWKJ,SUMSQS, + COORD,NCROWS,NPOLYS,DIMEN,NPTS,F,Z,C,PSIWID, + WEIGHT,ALFL,ONPLYS,STTDEG,ERROR) RETURN END SUBROUTINE DINCDG(DEGREE,ALPHA,PSI,INDEXS,NEWKJ, + SUMSQS,COORD,NCROWS,NPOLYS, + DIMEN,NPTS,F,Z,C,PSIWID,WEIGHT, + ALFL,ONPLYS,STTDEG,ERROR) C INTEGER JPRIME,P,J,CURDEG,KJ,KJP,L,JPM1,JM1 INTEGER M,START,JINDEX,JPINDX,Q,J3,J1,J1MJ2,ERROR INTEGER J0MJ1,J1M1,STARTA,ONPLYS,ONPP1,STTDEG,INDEX1,INDEX2 INTEGER DEGREE,NPOLYS,NPTS,DIMEN,PSIWID,ALFL INTEGER INDEXS(4,NPOLYS),NEWKJ(DIMEN,DEGREE) DOUBLE PRECISION ALPHA(ALFL),COORD(NCROWS,DIMEN),PSI(NPTS,PSIWID) DOUBLE PRECISION SUMSQS(NPOLYS),C(NPOLYS),F(NPTS),WEIGHT(NPTS) DOUBLE PRECISION Z(NPTS) DOUBLE PRECISION ARC,RUNTOT,RNTOT1,RNTOT2 C C *************** C PURPOSE C ------- C C THE MULTINOMIAL FIT IS GENERATED INCREMENTALLY, A BASIS ELEMENT C AT A TIME. THIS SUBROUTINE CONTINUES THE PROCESS STARTED OFF BY C DGNRTP . C C THIS SUBROUTINE IS CALLED BY DGNRTP AND NOT BY THE USER. C C C MODIFIED BY A.H. MORRIS (NSWC) C C **************** C IF ( ONPLYS .GE. 1 .AND. STTDEG .GE. 1 ) GO TO 10 ERROR = 6 RETURN 10 IF ( INDEXS(2,ONPLYS) .EQ. DIMEN ) GO TO 20 CURDEG = STTDEG GO TO 30 20 CURDEG = STTDEG + 1 30 ONPP1 = ONPLYS + 1 DO 170 J = ONPP1,NPOLYS JPRIME = INDEXS(1,J) JINDEX = J - ((J - 1) / PSIWID) * PSIWID JPINDX = JPRIME - ((JPRIME - 1) / PSIWID) * PSIWID KJ = INDEXS(2,J) START = INDEXS(3,J) M = START STARTA = INDEXS(4,J) - START IF ( CURDEG .EQ. 1 ) GO TO 100 KJP = INDEXS(2,JPRIME) J1 = NEWKJ(KJ,CURDEG - 1) C C *************** C CALCULATE THOSE ALPHA ( J , M ) THAT CAN BE CALCULATED FROM C PREVIOUSLY CALCULATED ALPHAS. C *************** C IF ( KJ .LT. KJP ) GO TO 50 C C *************** C FIRST CALCULATE THOSE BETWEEN JPP AND THE END OF 2 ROWS BACK. C CALCULATE ALPHA ( J , JPP ) C *************** C INDEX1 = INDEXS(4,J) ALPHA(INDEX1) = SUMSQS(JPRIME) / SUMSQS(START) C M = START + 1 J3 = NEWKJ(1,CURDEG - 1) - 1 IF ( M .GT. J3 ) GO TO 50 C C *************** C CURDEG .GT. 2 IF CONTROL HAS PASSED THE BRANCHES IN THE 3-RD C PREVIOUS AND 8-TH PREVIOUS STATEMENTS. C *************** C J1MJ2 = J1 - NEWKJ(KJ,CURDEG - 2) C DO 40 L = M,J3 Q = J1MJ2 + L INDEX1 = STARTA + L INDEX2 = INDEXS(4,Q) - INDEXS(3,Q) + JPRIME 40 ALPHA(INDEX1) = ALPHA(INDEX2) * SUMSQS(JPRIME) / + SUMSQS(L) C C *************** C CALCULATE ALPHA ( J , M ) FOR M BETWEEN THE 2 C RANGES CALCULATED BEFORE USING C C ALPHA ( J , L ) = (X * PSI ,PSI ) / (PSI ,PSI ) C K JP L L L C J C *************** C M = J3 + 1 50 IF ( JPRIME .EQ. J1 ) GO TO 100 IF ( KJ .EQ. 1 ) GO TO 80 J1M1 = J1 - 1 DO 70 L = M,J1M1 RUNTOT = 0.D0 DO 60 P = 1,NPTS INDEX1 = L - ((L - 1) / PSIWID) * PSIWID 60 RUNTOT = RUNTOT + COORD(P,KJ) * PSI(P,JPINDX) * + PSI(P,INDEX1) * WEIGHT(P) INDEX1 = STARTA + L 70 ALPHA(INDEX1) = RUNTOT / SUMSQS(L) C C *************** C CALCULATE ALPHA ( J , M ) FOR M BETWEEN C NEWKJ ( KJ , CURDEG - 1) AND C JP - 1. C *************** C 80 J0MJ1 = NEWKJ(KJ,CURDEG) - J1 JPM1 = JPRIME - 1 DO 90 L = J1,JPM1 Q = J0MJ1 + L INDEX1 = STARTA + L INDEX2 = INDEXS(4,Q) - INDEXS(3,Q) + JPRIME 90 ALPHA(INDEX1) = ALPHA(INDEX2) * SUMSQS(JPRIME) / + SUMSQS(L) M = JPRIME C C *************** C CALCULATE THE REMAINING ALPHA ( J , M ) FROM C C ALPHA ( J , L ) = (X * PSI ,PSI ) / (PSI ,PSI ) C K JP L L L C J C *************** C 100 JM1 = J - 1 DO 120 L = M,JM1 RUNTOT = 0.D0 DO 110 P = 1,NPTS INDEX1 = L - ((L - 1) / PSIWID) * PSIWID 110 RUNTOT = RUNTOT + COORD(P,KJ) * PSI(P,JPINDX) * + PSI(P,INDEX1) * WEIGHT(P) INDEX1 = STARTA + L 120 ALPHA(INDEX1) = RUNTOT / SUMSQS(L) C C *************** C NOW CALCULATE THE PSI (P,J), SUMSQS (J) AND C (J) USING C C J-1 C PSI = X * PSI - SUM ALPHA(J,L) * PSI C J K JP L=JPP L C C SUMSQS = (PSI ,PSI ) C J J J C C C = (Z,PSI ) C J J C *************** C 130 JM1 = J - 1 ARC = 0.D0 RNTOT1 = 0.D0 RNTOT2 = 0.D0 DO 150 P = 1,NPTS RUNTOT = COORD(P,KJ) * PSI(P,JPINDX) DO 140 L = START,JM1 INDEX1 = STARTA + L INDEX2 = L - ((L - 1) / PSIWID) * PSIWID 140 RUNTOT = RUNTOT - ALPHA(INDEX1) * PSI(P,INDEX2) PSI(P,JINDEX) = RUNTOT ARC = ARC + PSI(P,INDEX2) * PSI(P,JINDEX) * + WEIGHT(P) RNTOT1 = RNTOT1 + PSI(P,JINDEX) * PSI(P,JINDEX) * + WEIGHT(P) 150 RNTOT2 = RNTOT2 + Z(P) * PSI(P,JINDEX) * WEIGHT(P) IF (ARC * ARC .GE. SUMSQS(JM1) * RNTOT1 * 1.D-06) + GO TO 200 SUMSQS(J) = RNTOT1 C(J) = RNTOT2 / RNTOT1 C C *************** C CALCULATE THE NEW Z ( P ) AND THE NEW SSRES USING C C Z = Z - C * PSI C J J C *************** C DO 160 P = 1,NPTS 160 Z(P) = Z(P) - C(J) * PSI(P,JINDEX) STTDEG = CURDEG 170 IF ( KJ .EQ. DIMEN ) CURDEG = CURDEG + 1 RETURN C C *************** C THE J-TH BASIS MULTINOMIAL CANNOT BE COMPUTED ACCURATELY. C ONLY J - 1 BASIS MULTINOMIALS ARE GENERATED. C *************** C 200 ERROR = -1 DEGREE = STTDEG NPOLYS = JM1 RETURN END SUBROUTINE DSCALP(COORD,NPTS,MAXABS) C INTEGER NPTS,P DOUBLE PRECISION MAXABS,A DOUBLE PRECISION COORD(NPTS) C C *************** C PURPOSE C ------- C C FIND SCALING PARAMETER(S) FOR THE PROBLEM. IF THE SCALING SCHEME C IS CHANGED, ALL FOUR OF THE FOLLOWING WOULD HAVE TO BE CHANGED C C 1) DSCALP - FIND THE SCALING PARAMETERS C 2) DSCALD - SCALE THE PROBLEM DATA C 3) THE SCALING OF THE RESIDUALS IN DMFIT C 4) THE SCALING PERFORMED IN DMEVL1 C C THIS SUBROUTINE IS CALLED BY DGNRTP . IT IS NOT CALLED BY THE C USER. C C THE SCALING WHICH IT DEFINES MUST BE COORDINATED WITH THE C SCALING OF RESIDUALS WHICH IS CARRIED OUT TOWARD THE END OF THE C SUBROUTINE DMFIT. THE SCALING MUST ALSO BE COORDINATED WITH THE C SCALING PERFORMED IN THE 10 LOOP AND AT STATEMENTS 40 AND 50 C (WITH THE SCALE FACTOR MAXABS(DIMP1)) IN DMEVL1. C C **************** C MAXABS = 0.D0 DO 10 P = 1,NPTS A = DABS(COORD(P)) 10 IF ( A .GT. MAXABS ) MAXABS = A RETURN END SUBROUTINE DSCALD(COORD,NPTS,MAXABS) C INTEGER NPTS,P DOUBLE PRECISION MAXABS DOUBLE PRECISION COORD(NPTS) C C *************** C PURPOSE C ------- C C CARRY OUT THE DATA-SCALING WHICH IS DEFINED BY THE SUBROUTINE C DSCALP . C C THIS SUBROUTINE IS CALLED BY DGNRTP . IT IS NOT CALLED BY THE C USER. C C THE SCALING WHICH THIS ROUTINE CARRIES OUT MUST BE CONSISTENT C WITH THE SCALING IN THE SUBROUTINES DMFIT AND DMEVL1. C C **************** C IF ( MAXABS .EQ. 0.0D+00 ) RETURN DO 10 P = 1,NPTS 10 COORD(P) = COORD(P) / MAXABS RETURN END SUBROUTINE DMEVAL(DIMEN,EVLDEG,NEPOLS,NEPTS,EVLCDS,NEROWS,EVLVLS, + ERROR,FITIWK,FITDWK,FIWKLN,FDWKLN,TEMP) C INTEGER FIWKLN,FDWKLN,NEPOLS,NEPTS,DIMEN,ERROR,MAXSTT,ALFSTT,CSTT INTEGER GBASIZ,ALFL,DIMP1,EVLDEG,TOP,BOT,CURDEG,PSISTT INTEGER FITIWK(FIWKLN) DOUBLE PRECISION FITDWK(FDWKLN),EVLCDS(NEROWS,DIMEN) DOUBLE PRECISION EVLVLS(NEPTS),TEMP(DIMEN) C C *************** C PURPOSE C ------- C C THIS SUBROUTINE EVALUATES THE LEAST-SQUARES MULTINOMIAL FIT C WHICH HAS BEEN PREVIOUSLY PRODUCED BY DMFIT . THE COMPUTATION C IS PERFORMED IN DOUBLE PRECISION. EITHER THE FULL C MULTINOMIAL AS PRODUCED MAY BE EVALUATED, OR ONLY AN INITIAL C SEGMENT THEREOF. AS IN THE CASE WITH DMFIT , IT IS POSSIBLE C (1) TO SPECIFY MULTINOMIALS OF A FULL GIVEN DEGREE, OR C (2) TO SPECIFY THE NUMBER OF ORTHOGONAL BASIS ELEMENTS TO C ACHIEVE A PARTIAL-DEGREE FIT. C C IN CASE (1), THE DESIRED DEGREE IS GIVEN AS THE VALUE OF C EVLDEG (WHICH MUST BE NONNEGATIVE AND NOT GREATER THAN THE C VALUE USED FOR FITDEG IN DMFIT ), AND THE PARAMETER NEPOLS C WILL BE SET BY DMEVAL TO SPECIFY THE NUMBER OF BASIS ELEMENTS C REQUIRED. IF EVLDEG .LT. FITDEG IS GIVEN, THEN ONLY THE C INITIAL PORTION OF THE FITTING MULTINOMIAL (OF DEGREE EVLDEG ) C WILL BE EVALUATED. C C IN CASE (2), EVLDEG IS TO BE SET NEGATIVE, IN WHICH CASE THE C VALUE OF NEPOLS (WHICH MUST BE POSITIVE AND NOT GREATER THAN C THE VALUE USED FOR NFPOLS IN DMFIT ) WILL BE TAKEN AS C DEFINING THE INITIAL PORTION OF THE FITTING MULTINOMIAL TO BE C EVALUATED. C C IF NEPOLS = NFPOLS (WITH EVLDEG .LT. 0), OR EVLDEG = C FITDEG (WITH EVLDEG .GT. 0), THEN THE FULL MULTINOMIAL C GENERATED BY DMFIT WILL BE EVALUATED. C C THE EVALUATION WILL TAKE PLACE FOR EACH OF THE POINTS C (COLLECTION OF VARIABLE VALUES) GIVEN AS A ROW OF THE MATRIX C EVLCDS . THE VALUES PRODUCED FROM THE FULL, OR PARTIAL, C MULTINOMIAL WILL BE PLACED IN THE ARRAY EVLVLS . C C VARIABLES C --------- C C DIMEN -- (INTEGER) -- (PASSED) C THE NUMBER OF VARIABLES. C EVLDEG -- (INTEGER) -- (PASSED) C IF EVLDEG .LT. 0, THEN THIS PARAMETER WILL BE IGNORED. C IF EVLDEG .GE. 0, THEN THE VALUE OF EVLDEG MUST SATISFY C EVLDEG .LE. (THE DEGREE OF THE APPROXIMATING MULTINOMIAL C GENERATED IN DMFIT ). IN THIS CASE EVLDEG WILL SPECIFY C THE DEGREE OF THE INITIAL PORTION OF THE FITTING MULTINOMIAL C TO BE EVALUATED. C NEPOLS -- (INTEGER) -- (PASSED/RETURNED) C IF EVLDEG .GE. 0, THEN THIS PARAMETER WILL BE IGNORED. C IF EVLDEG .LT. 0, THEN THE PARTIAL MULTINOMIAL INVOLVING THE C FIRST NEPOLS ORTHOGONAL BASIS FUNCTIONS WILL BE EVALUATED C AT THE POINTS GIVEN BY EVLCDS . THE RESULTING VALUES WILL C BE STORED IN EVLVLS . C THE VALUE OF NEPOLS MUST BE .GE. 1 AND .LE. (THE SIZE OF THE C BASIS GENERATED IN DMFIT ), WHICH WAS RETURNED AS THE C VALUE OF NFPOLS . C NEPOLS WILL BE CHANGED IF EVLDEG .GT. 0 TO GIVE THE SIZE OF C BASIS REQUIRED FOR THE MULTINOMIAL OF DEGREE EVLDEG . C NEPTS -- (INTEGER) -- (PASSED) C THE NUMBER OF EVALUATION POINTS. C EVLCDS -- (DOUBLE PRECISION 2-SUBSCRIPT ARRAY) -- (PASSED) C EVLCDS (P,K) IS THE VALUE OF THE K-TH VARIABLE AT THE P-TH C EVALUATION POINT. C NEROWS -- (INTEGER) -- (PASSED) C THE ROW DIMENSION DECLARED FOR EVLCDS IN THE CALLING PROGRAM. C EVLVLS -- (INTEGER) -- (RETURNED) C EVLVLS (P) IS THE VALUE OF THE EVALUATED MULTINOMIAL AT THE C P-TH EVALUATION POINT. C ERROR -- (INTEGER) -- (RETURNED) C 0 ......... IF NO ERRORS C -1 ......... IF NEPOLS .GT. NFPOLS OR NEPOLS .LT. 1 C -2 ......... IF NEPTS .LT. 1 OR DIMEN .LT. 1 C FITIWK -- (INTEGER, 1-SUBSCRIPT ARRAY) -- (PASSED) C THE INTEGER WORK ARRAY OF LENGTH FIWKLN THAT WAS USED IN C DMFIT . C FITDWK -- (DOUBLE PRECISION 2-SUBSCRIPT ARRAY) -- (PASSED) C THE REAL WORK ARRAY OF LENGTH FDWKLN THAT WAS C USED IN DMFIT . C FIWKLN -- (INTEGER) -- (PASSED) C THE LENGTH OF FITIWK . C FDWKLN -- (INTEGER) -- (PASSED) C THE LENGTH OF FITDWK . C TEMP -- (DOUBLE PRECISION 1-SUBSCRIPT ARRAY) C A WORK ARRAY OF LENGTH DIMEN (OR LONGER). C C THE SUBROUTINE DMEVL1 IS CALLED TO DO THE ACTUAL EVALUATION. C C MODIFIED BY A.H. MORRIS (NSWC) C C **************** C C C *************** C SET UP INDEX POINTERS TO THE BEGINNING OF EACH ROW OF C THE MTABLE -- THIS SETS THE BEGINNING POINT FOR EACH C FULL MULTINOMIAL DEGREE. C *************** C IF (NEPTS .LT. 1 .OR. DIMEN .LT. 1) GO TO 110 IF (EVLDEG) 40,10,20 C 10 NEPOLS = 1 GO TO 50 C 20 TOP = 1 BOT = 1 DO 30 CURDEG = 1,EVLDEG TOP = TOP * (DIMEN + CURDEG) 30 BOT = BOT * CURDEG NEPOLS = TOP / BOT C 40 GBASIZ = FITIWK(1) IF (NEPOLS .GT. GBASIZ .OR. NEPOLS .LT. 1) GO TO 100 C 50 ERROR = 0 DIMP1 = DIMEN + 1 ALFL = FITIWK(4) MAXSTT = 1 ALFSTT = DIMP1 + MAXSTT CSTT = ALFSTT + ALFL PSISTT = CSTT + FITIWK(2) C C *************** C THE ACTUAL EVALUATION IS DONE INSIDE DMEVL1. C *************** C CALL DMEVL1 (EVLCDS,NEROWS,FITDWK(CSTT),NEPTS,DIMEN,NEPOLS, + FITDWK(ALFSTT),FITIWK,FITDWK(PSISTT), + EVLVLS,ALFL,FITDWK(MAXSTT),TEMP,DIMP1) RETURN C C *************** C ERROR RETURN C *************** C 100 ERROR = -1 RETURN 110 ERROR = -2 RETURN END SUBROUTINE DMEVL1 (COORD,NCROWS,C,NEPTS,DIMEN,NPOLYS,ALPHA, + INDEXS,PSI,F,ALFL,MAXABS,X,DIMP1) C INTEGER DIMEN,NEPTS,NPOLYS,ALFL,DIMP1 INTEGER JM1,JPRIME,M,P,K,I,J,INDEX INTEGER INDEXS(4,NPOLYS) DOUBLE PRECISION ALPHA(ALFL),COORD(NCROWS,DIMEN),PSI(NPOLYS) DOUBLE PRECISION C(NPOLYS),F(NEPTS),MAXABS(DIMP1),X(DIMEN) DOUBLE PRECISION RUNTOT,RNTOT1 C C *************** C PURPOSE C ------- C C THIS SUBROUTINE PERFORMS THE MAIN WORK OF EVALUATING THE C FITTING MULTINOMIAL (OR THE INITIAL PORTION OF IT WHICH C IS REQUESTED BY THE SETTING OF NEPOLS , EVLDEG IN THE C CALL TO SUBROUTINE DMEVAL . C C THIS SUBROUTINE IS CALLED BY DMEVAL . IT IS NOT CALLED C DIRECTLY BY THE USER. C C THE BODY OF THIS SUBROUTINE FOLLOWS THE EXPLANATION C GIVEN IN C LEAST SQUARES FITTING USING C ORTHOGONAL MULTINOMIALS C BY C BARTELS AND JEZIORANSKI C IN C ACM TRANSACTIONS ON MATHEMATICAL SOFTWARE C C C MODIFIED BY A.H. MORRIS (NSWC) C C **************** C IF (NPOLYS .EQ. 1) GO TO 50 C PSI(1) = 1.D0 DO 40 P = 1,NEPTS C C *************** C SCALE THE COORDINATES OF THE P-TH POINT C *************** C DO 10 K = 1,DIMEN X(K) = COORD(P,K) IF (MAXABS(K) .NE. 0.D0) X(K) = X(K) / MAXABS(K) 10 CONTINUE C C *************** C USE THE BASIS FUNCTION COEFFICIENTS C AND RECURRENCE C COEFFICIENTS ALPHA TO EVALUATE THE FITTED MULTINOMIAL C AT THE P-TH POINT. C *************** C RNTOT1 = C(1) DO 30 J = 2,NPOLYS K = INDEXS(2,J) JPRIME = INDEXS(1,J) RUNTOT = X(K) * PSI(JPRIME) I = INDEXS(3,J) JM1 = J - 1 DO 20 M = I,JM1 INDEX = INDEXS(4,J) + M - I 20 RUNTOT = RUNTOT - PSI(M) * ALPHA(INDEX) PSI(J) = RUNTOT 30 RNTOT1 = RNTOT1 + C(J) * PSI(J) 40 F(P) = RNTOT1 * MAXABS(DIMP1) RETURN C C *************** C COMPUTE THE DEGREE 0 POLYNOMIAL C *************** C 50 RUNTOT = C(1) * MAXABS(DIMP1) DO 60 P = 1,NEPTS 60 F(P) = RUNTOT RETURN END REAL FUNCTION QSUBA (F, A, B, EPSIL, MCOUNT, RELERR, IND) C----------------------------------------------------------------------- C C INTEGRATION OVER A FINITE INTERVAL C C ---------- C C QSUBA COMPUTES THE INTEGRAL OF F(X) FROM A TO B WHERE THE C RELATIVE ERROR DOES NOT EXCEED EPSIL. C C MCOUNT IS THE MAXIMUM NUMBER OF POINTS AT WHICH F(X) MAY BE C EVALUATED. C C RELERR IS A VARIABLE. WHEN QSUBA TERMINATES, IF THE VALUE C OF THE INTEGRAL IS NONZERO THEN RELERR IS A CRUDE ESTIMATE C OF THE RELATIVE ERROR OF THE VALUE. OTHERWISE, IF QSUBA = 0 C THEN RELERR IS AN ESTIMATE OF THE ABSOLUTE ERROR. C C IND IS A VARIABLE. WHEN QSUBA TERMINATES, IND HAS ONE OF THE C FOLLOWING VALUES ... C C IND=0 QSUBA IS SATISFIED THAT THE INTEGRAL HAS BEEN C COMPUTED TO THE DESIRED ACCURACY. C IND=1 THE INTEGRAL HAS BEEN COMPUTED, BUT QSUBA IS C NOT CERTAIN OF THE ACCURACY OF THE RESULT. C IND=2 THE INTEGRAND HAS BEEN EVALUATED AT MCOUNT C POINTS. IF MORE EVALUATIONS ARE NEEDED THEN C QSUBA TERMINATES. C IND=3 QSUBA CANNOT COMPUTE THE INTEGRAL TO THE DESIRED C ACCURACY. IND IS SET TO 3 WHENEVER THE STACK OF C INTERVALS BECOMES FULL (IT CURRENTLY CAN HOLD 50 C INTERVALS). A RESULT IS OBTAINED BY CONTINUING C THE INTEGRATION IGNORING CONVERGENCE FAILURES C WHICH CANNOT BE ACCOMMODATED ON THE STACK. C C THE RELIABILITY OF THE ALGORITHM DECREASES FOR LARGE VALUES C OF EPSIL. IT IS RECOMMENDED THAT EPSIL BE LESS THAN 0.001. C C----------------------------------------------------------------------- DIMENSION RESULT(8), STACK(100) EXTERNAL F DATA ISMAX/100/ C----------------------------------------------------------------------- C C ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE C SMALLEST NUMBER SUCH THAT 1.0 + EPS .GT. 1.0. C EPS = SPMPAR(1) C C----------------------------------------------------------------------- QSUBA = 0.0 RELERR = 0.0 IND = 0 IF (A .EQ. B) RETURN C C APPLY QUAD TO THE ENTIRE INTERVAL C SUB1 = AMIN1(A,B) SUB3 = AMAX1(A,B) TOL = AMAX1(EPSIL, 10.0*EPS) CALL QUAD (SUB1, SUB3, RESULT, K, TOL, NPTS, ICHECK, F) IF (ICHECK .EQ. 0) GO TO 100 IS = 1 C C SUBDIVIDE THE INTERVAL (SUB1,SUB3) INTO THE SUBINTERVALS C (SUB1,SUB2) AND (SUB2,SUB3). CALL QUAD FOR (SUB1,SUB2). C 10 IF (NPTS .GE. MCOUNT) GO TO 110 SUB2 = 0.5*(SUB1 + SUB3) CALL QUAD (SUB1, SUB2, RESULT, K, TOL, NF, ICHECK, F) NPTS = NPTS + NF ERR = ABS(RESULT(K) - RESULT(K-1)) SUM = QSUBA + RESULT(K) IF (ICHECK .EQ. 0 .OR. ERR .LE. ABS(TOL*SUM)) GO TO 30 C C STACK THE SUBINTERVAL (SUB1,SUB2) FOR FURTHER C EXAMINATION IF THERE IS SUFFICIENT STORAGE. C IF (IS .GE. ISMAX) GO TO 20 STACK(IS) = SUB1 IS = IS + 1 STACK(IS) = SUB2 IS = IS + 1 GO TO 40 20 IND = 3 C C UPDATE QSUBA AND CHECK IF ANY SIGNIFICANT DIGITS ARE LOST C 30 X = QSUBA QSUBA = SUM RELERR = RELERR + ERR IF (IND .NE. 0 .OR. X*RESULT(K) .GE. 0.0) GO TO 40 X = 0.1*AMIN1(ABS(X),ABS(RESULT(K))) IF (ABS(QSUBA) .LE. X) IND = 1 C C CALL QUAD FOR THE INTERVAL (SUB2,SUB3) C 40 IF (NPTS .GE. MCOUNT) GO TO 110 CALL QUAD (SUB2, SUB3, RESULT, K, TOL, NF, ICHECK, F) NPTS = NPTS + NF ERR = ABS(RESULT(K) - RESULT(K-1)) SUM = QSUBA + RESULT(K) IF (ICHECK .EQ. 0 .OR. ERR .LE. ABS(TOL*SUM)) GO TO 50 C C SUBDIVIDE THE INTERVAL (SUB2,SUB3) C SUB1 = SUB2 GO TO 10 C C UPDATE QSUBA AND CHECK IF ANY SIGNIFICANT DIGITS ARE LOST C 50 X = QSUBA QSUBA = SUM RELERR = RELERR + ERR IF (IND .NE. 0 .OR. X*RESULT(K) .GE. 0.0) GO TO 60 X = 0.1*AMIN1(ABS(X),ABS(RESULT(K))) IF (ABS(QSUBA) .LE. X) IND = 1 C C SUBDIVIDE THE INTERVAL LAST STACKED C 60 IF (IS .EQ. 1) GO TO 120 IS = IS - 1 SUB3 = STACK(IS) IS = IS - 1 SUB1 = STACK(IS) GO TO 10 C C TERMINATION WHEN SUBDIVISION IS NOT NEEDED C 100 QSUBA = RESULT(K) IF (A .GT. B) QSUBA = -QSUBA RELERR = ABS(RESULT(K) - RESULT(K-1)) IF (QSUBA .NE. 0.0) RELERR = RELERR/ABS(QSUBA) RETURN C C SUBDIVISION RESULT C 110 IND = 2 120 IF (A .GT. B) QSUBA = -QSUBA IF (QSUBA .NE. 0.0) RELERR = RELERR/ABS(QSUBA) RETURN END SUBROUTINE QUAD(A, B, RESULT, K, EPSIL, NPTS, ICHECK, F) C -------------------- C THIS SUBROUTINE ATTEMPTS TO CALCULATE THE INTEGRAL OF F(X) C OVER THE INTERVAL *A* TO *B* WITH RELATIVE ERROR NOT C EXCEEDING *EPSIL*. C THE RESULT IS OBTAINED USING A SEQUENCE OF 1,3,7,15,31,63, C 127, AND 255 POINT INTERLACING FORMULAE(NO INTEGRAND C EVALUATIONS ARE WASTED) OF RESPECTIVE DEGREE 1,5,11,23, C 47,95,191 AND 383. THE FORMULAE ARE BASED ON THE OPTIMAL C EXTENSION OF THE 3-POINT GAUSS FORMULA. DETAILS OF C THE FORMULAE ARE GIVEN IN *THE OPTIMUM ADDITION OF POINTS C TO QUADRATURE FORMULAE* BY T.N.L. PATTERSON,MATHS.COMP. C VOL 22,847-856,1968. C *** INPUT *** C A LOWER LIMIT OF INTEGRATION. C B UPPER LIMIT OF INTEGRATION. C EPSIL RELATIVE ACCURACY REQUIRED. WHEN THE RELATIVE C DIFFERENCE OF TWO SUCCESSIVE FORMULAE DOES NOT C EXCEED *EPSIL* THE LAST FORMULA COMPUTED IS TAKEN C AS THE RESULT. C F F(X) IS THE INTEGRAND. C *** OUTPUT *** C RESULT THIS ARRAY,WHICH SHOULD BE DECLARED TO HAVE AT C LEAST 8 ELEMENTS, HOLDS THE RESULTS OBTAINED BY C THE 1,3,7, ETC., POINT FORMULAE. THE NUMBER OF C FORMULAE COMPUTED DEPENTS ON *EPSIL*. C K RESULT(K) HOLDS THE VALUE OF THE INTEGRAL TO THE C SPECIFIED RELATIVE ACCURACY. C NPTS NUMBER INTEGRAND EVALUATIONS. C ICHECK ON EXIT NORMALLY ICHECK=0. HOWEVER IF CONVERGENCE C TO THE ACCURACY REQUESTED IS NOT ACHIEVED ICHECK=1 C ON EXIT. C ABSCISSAE AND WEIGHTS OF QUADRATURE RULES ARE STACKED IN C ARRAY *P* IN THE ORDER IN WHICH THEY ARE NEEDED. C -------------------- DIMENSION FUNCT(127), P(381), RESULT(*) EXTERNAL F DATA * P( 1),P( 2),P( 3),P( 4),P( 5),P( 6),P( 7), * P( 8),P( 9),P(10),P(11),P(12),P(13),P(14), * P(15),P(16),P(17),P(18),P(19),P(20),P(21), * P(22),P(23),P(24),P(25),P(26),P(27),P(28)/ * 0.77459666924148337704E 00,0.55555555555555555556E 00, * 0.88888888888888888889E 00,0.26848808986833344073E 00, * 0.96049126870802028342E 00,0.10465622602646726519E 00, * 0.43424374934680255800E 00,0.40139741477596222291E 00, * 0.45091653865847414235E 00,0.13441525524378422036E 00, * 0.51603282997079739697E-01,0.20062852937698902103E 00, * 0.99383196321275502221E 00,0.17001719629940260339E-01, * 0.88845923287225699889E 00,0.92927195315124537686E-01, * 0.62110294673722640294E 00,0.17151190913639138079E 00, * 0.22338668642896688163E 00,0.21915685840158749640E 00, * 0.22551049979820668739E 00,0.67207754295990703540E-01, * 0.25807598096176653565E-01,0.10031427861179557877E 00, * 0.84345657393211062463E-02,0.46462893261757986541E-01, * 0.85755920049990351154E-01,0.10957842105592463824E 00/ DATA * P(29),P(30),P(31),P(32),P(33),P(34),P(35), * P(36),P(37),P(38),P(39),P(40),P(41),P(42), * P(43),P(44),P(45),P(46),P(47),P(48),P(49), * P(50),P(51),P(52),P(53),P(54),P(55),P(56)/ * 0.99909812496766759766E 00,0.25447807915618744154E-02, * 0.98153114955374010687E 00,0.16446049854387810934E-01, * 0.92965485742974005667E 00,0.35957103307129322097E-01, * 0.83672593816886873550E 00,0.56979509494123357412E-01, * 0.70249620649152707861E 00,0.76879620499003531043E-01, * 0.53131974364437562397E 00,0.93627109981264473617E-01, * 0.33113539325797683309E 00,0.10566989358023480974E 00, * 0.11248894313318662575E 00,0.11195687302095345688E 00, * 0.11275525672076869161E 00,0.33603877148207730542E-01, * 0.12903800100351265626E-01,0.50157139305899537414E-01, * 0.42176304415588548391E-02,0.23231446639910269443E-01, * 0.42877960025007734493E-01,0.54789210527962865032E-01, * 0.12651565562300680114E-02,0.82230079572359296693E-02, * 0.17978551568128270333E-01,0.28489754745833548613E-01/ DATA * P(57),P(58),P(59),P(60),P(61),P(62),P(63), * P(64),P(65),P(66),P(67),P(68),P(69),P(70), * P(71),P(72),P(73),P(74),P(75),P(76),P(77), * P(78),P(79),P(80),P(81),P(82),P(83),P(84)/ * 0.38439810249455532039E-01,0.46813554990628012403E-01, * 0.52834946790116519862E-01,0.55978436510476319408E-01, * 0.99987288812035761194E 00,0.36322148184553065969E-03, * 0.99720625937222195908E 00,0.25790497946856882724E-02, * 0.98868475754742947994E 00,0.61155068221172463397E-02, * 0.97218287474858179658E 00,0.10498246909621321898E-01, * 0.94634285837340290515E 00,0.15406750466559497802E-01, * 0.91037115695700429250E 00,0.20594233915912711149E-01, * 0.86390793819369047715E 00,0.25869679327214746911E-01, * 0.80694053195021761186E 00,0.31073551111687964880E-01, * 0.73975604435269475868E 00,0.36064432780782572640E-01, * 0.66290966002478059546E 00,0.40715510116944318934E-01, * 0.57719571005204581484E 00,0.44914531653632197414E-01, * 0.48361802694584102756E 00,0.48564330406673198716E-01/ DATA * P( 85),P( 86),P( 87),P( 88),P( 89),P( 90),P( 91), * P( 92),P( 93),P( 94),P( 95),P( 96),P( 97),P( 98), * P( 99),P(100),P(101),P(102),P(103),P(104),P(105), * P(106),P(107),P(108),P(109),P(110),P(111),P(112)/ * 0.38335932419873034692E 00,0.51583253952048458777E-01, * 0.27774982202182431507E 00,0.53905499335266063927E-01, * 0.16823525155220746498E 00,0.55481404356559363988E-01, * 0.56344313046592789972E-01,0.56277699831254301273E-01, * 0.56377628360384717388E-01,0.16801938574103865271E-01, * 0.64519000501757369228E-02,0.25078569652949768707E-01, * 0.21088152457266328793E-02,0.11615723319955134727E-01, * 0.21438980012503867246E-01,0.27394605263981432516E-01, * 0.63260731936263354422E-03,0.41115039786546930472E-02, * 0.89892757840641357233E-02,0.14244877372916774306E-01, * 0.19219905124727766019E-01,0.23406777495314006201E-01, * 0.26417473395058259931E-01,0.27989218255238159704E-01, * 0.18073956444538835782E-03,0.12895240826104173921E-02, * 0.30577534101755311361E-02,0.52491234548088591251E-02/ DATA * P(113),P(114),P(115),P(116),P(117),P(118),P(119), * P(120),P(121),P(122),P(123),P(124),P(125),P(126), * P(127),P(128),P(129),P(130),P(131),P(132),P(133), * P(134),P(135),P(136),P(137),P(138),P(139),P(140)/ * 0.77033752332797418482E-02,0.10297116957956355524E-01, * 0.12934839663607373455E-01,0.15536775555843982440E-01, * 0.18032216390391286320E-01,0.20357755058472159467E-01, * 0.22457265826816098707E-01,0.24282165203336599358E-01, * 0.25791626976024229388E-01,0.26952749667633031963E-01, * 0.27740702178279681994E-01,0.28138849915627150636E-01, * 0.99998243035489159858E 00,0.50536095207862517625E-04, * 0.99959879967191068325E 00,0.37774664632698466027E-03, * 0.99831663531840739253E 00,0.93836984854238150079E-03, * 0.99572410469840718851E 00,0.16811428654214699063E-02, * 0.99149572117810613240E 00,0.25687649437940203731E-02, * 0.98537149959852037111E 00,0.35728927835172996494E-02, * 0.97714151463970571416E 00,0.46710503721143217474E-02, * 0.96663785155841656709E 00,0.58434498758356395076E-02/ DATA * P(141),P(142),P(143),P(144),P(145),P(146),P(147), * P(148),P(149),P(150),P(151),P(152),P(153),P(154), * P(155),P(156),P(157),P(158),P(159),P(160),P(161), * P(162),P(163),P(164),P(165),P(166),P(167),P(168)/ * 0.95373000642576113641E 00,0.70724899954335554680E-02, * 0.93832039777959288365E 00,0.83428387539681577056E-02, * 0.92034002547001242073E 00,0.96411777297025366953E-02, * 0.89974489977694003664E 00,0.10955733387837901648E-01, * 0.87651341448470526974E 00,0.12275830560082770087E-01, * 0.85064449476835027976E 00,0.13591571009765546790E-01, * 0.82215625436498040737E 00,0.14893641664815182035E-01, * 0.79108493379984836143E 00,0.16173218729577719942E-01, * 0.75748396638051363793E 00,0.17421930159464173747E-01, * 0.72142308537009891548E 00,0.18631848256138790186E-01, * 0.68298743109107922809E 00,0.19795495048097499488E-01, * 0.64227664250975951377E 00,0.20905851445812023852E-01, * 0.59940393024224289297E 00,0.21956366305317824939E-01, * 0.55449513263193254887E 00,0.22940964229387748761E-01/ DATA * P(169),P(170),P(171),P(172),P(173),P(174),P(175), * P(176),P(177),P(178),P(179),P(180),P(181),P(182), * P(183),P(184),P(185),P(186),P(187),P(188),P(189), * P(190),P(191),P(192),P(193),P(194),P(195),P(196)/ * 0.50768775753371660215E 00,0.23854052106038540080E-01, * 0.45913001198983233287E 00,0.24690524744487676909E-01, * 0.40897982122988867241E 00,0.25445769965464765813E-01, * 0.35740383783153215238E 00,0.26115673376706097680E-01, * 0.30457644155671404334E 00,0.26696622927450359906E-01, * 0.25067873030348317661E 00,0.27185513229624791819E-01, * 0.19589750271110015392E 00,0.27579749566481873035E-01, * 0.14042423315256017459E 00,0.27877251476613701609E-01, * 0.84454040083710883710E-01,0.28076455793817246607E-01, * 0.28184648949745694339E-01,0.28176319033016602131E-01, * 0.28188814180192358694E-01,0.84009692870519326354E-02, * 0.32259500250878684614E-02,0.12539284826474884353E-01, * 0.10544076228633167722E-02,0.58078616599775673635E-02, * 0.10719490006251933623E-01,0.13697302631990716258E-01/ DATA * P(197),P(198),P(199),P(200),P(201),P(202),P(203), * P(204),P(205),P(206),P(207),P(208),P(209),P(210), * P(211),P(212),P(213),P(214),P(215),P(216),P(217), * P(218),P(219),P(220),P(221),P(222),P(223),P(224)/ * 0.31630366082226447689E-03,0.20557519893273465236E-02, * 0.44946378920320678616E-02,0.71224386864583871532E-02, * 0.96099525623638830097E-02,0.11703388747657003101E-01, * 0.13208736697529129966E-01,0.13994609127619079852E-01, * 0.90372734658751149261E-04,0.64476204130572477933E-03, * 0.15288767050877655684E-02,0.26245617274044295626E-02, * 0.38516876166398709241E-02,0.51485584789781777618E-02, * 0.64674198318036867274E-02,0.77683877779219912200E-02, * 0.90161081951956431600E-02,0.10178877529236079733E-01, * 0.11228632913408049354E-01,0.12141082601668299679E-01, * 0.12895813488012114694E-01,0.13476374833816515982E-01, * 0.13870351089139840997E-01,0.14069424957813575318E-01, * 0.25157870384280661489E-04,0.18887326450650491366E-03, * 0.46918492424785040975E-03,0.84057143271072246365E-03/ DATA * P(225),P(226),P(227),P(228),P(229),P(230),P(231), * P(232),P(233),P(234),P(235),P(236),P(237),P(238), * P(239),P(240),P(241),P(242),P(243),P(244),P(245), * P(246),P(247),P(248),P(249),P(250),P(251),P(252)/ * 0.12843824718970101768E-02,0.17864463917586498247E-02, * 0.23355251860571608737E-02,0.29217249379178197538E-02, * 0.35362449977167777340E-02,0.41714193769840788528E-02, * 0.48205888648512683476E-02,0.54778666939189508240E-02, * 0.61379152800413850435E-02,0.67957855048827733948E-02, * 0.74468208324075910174E-02,0.80866093647888599710E-02, * 0.87109650797320868736E-02,0.93159241280693950932E-02, * 0.98977475240487497440E-02,0.10452925722906011926E-01, * 0.10978183152658912470E-01,0.11470482114693874380E-01, * 0.11927026053019270040E-01,0.12345262372243838455E-01, * 0.12722884982732382906E-01,0.13057836688353048840E-01, * 0.13348311463725179953E-01,0.13592756614812395910E-01, * 0.13789874783240936517E-01,0.13938625738306850804E-01, * 0.14038227896908623303E-01,0.14088159516508301065E-01/ DATA * P(253),P(254),P(255),P(256),P(257),P(258),P(259), * P(260),P(261),P(262),P(263),P(264),P(265),P(266), * P(267),P(268),P(269),P(270),P(271),P(272),P(273), * P(274),P(275),P(276),P(277),P(278),P(279),P(280)/ * 0.99999759637974846462E 00,0.69379364324108267170E-05, * 0.99994399620705437576E 00,0.53275293669780613125E-04, * 0.99976049092443204733E 00,0.13575491094922871973E-03, * 0.99938033802502358193E 00,0.24921240048299729402E-03, * 0.99874561446809511470E 00,0.38974528447328229322E-03, * 0.99780535449595727456E 00,0.55429531493037471492E-03, * 0.99651414591489027385E 00,0.74028280424450333046E-03, * 0.99483150280062100052E 00,0.94536151685852538246E-03, * 0.99272134428278861533E 00,0.11674841174299594077E-02, * 0.99015137040077015918E 00,0.14049079956551446427E-02, * 0.98709252795403406719E 00,0.16561127281544526052E-02, * 0.98351865757863272876E 00,0.19197129710138724125E-02, * 0.97940628167086268381E 00,0.21944069253638388388E-02, * 0.97473445975240266776E 00,0.24789582266575679307E-02/ DATA * P(281),P(282),P(283),P(284),P(285),P(286),P(287), * P(288),P(289),P(290),P(291),P(292),P(293),P(294), * P(295),P(296),P(297),P(298),P(299),P(300),P(301), * P(302),P(303),P(304),P(305),P(306),P(307),P(308)/ * 0.96948465950245923177E 00,0.27721957645934509940E-02, * 0.96364062156981213252E 00,0.30730184347025783234E-02, * 0.95718821610986096274E 00,0.33803979910869203823E-02, * 0.95011529752129487656E 00,0.36933779170256508183E-02, * 0.94241156519108305981E 00,0.40110687240750233989E-02, * 0.93406843615772578800E 00,0.43326409680929828545E-02, * 0.92507893290707565236E 00,0.46573172997568547773E-02, * 0.91543758715576504064E 00,0.49843645647655386012E-02, * 0.90514035881326159519E 00,0.53130866051870565663E-02, * 0.89418456833555902286E 00,0.56428181013844441585E-02, * 0.88256884024734190684E 00,0.59729195655081658049E-02, * 0.87029305554811390585E 00,0.63027734490857587172E-02, * 0.85735831088623215653E 00,0.66317812429018878941E-02, * 0.84376688267270860104E 00,0.69593614093904229394E-02/ DATA * P(309),P(310),P(311),P(312),P(313),P(314),P(315), * P(316),P(317),P(318),P(319),P(320),P(321),P(322), * P(323),P(324),P(325),P(326),P(327),P(328),P(329), * P(330),P(331),P(332),P(333),P(334),P(335),P(336)/ * 0.82952219463740140018E 00,0.72849479805538070639E-02, * 0.81462878765513741344E 00,0.76079896657190565832E-02, * 0.79909229096084140180E 00,0.79279493342948491103E-02, * 0.78291939411828301639E 00,0.82443037630328680306E-02, * 0.76611781930376009072E 00,0.85565435613076896192E-02, * 0.74869629361693660282E 00,0.88641732094824942641E-02, * 0.73066452124218126133E 00,0.91667111635607884067E-02, * 0.71203315536225203459E 00,0.94636899938300652943E-02, * 0.69281376977911470289E 00,0.97546565363174114611E-02, * 0.67301883023041847920E 00,0.10039172044056840798E-01, * 0.65266166541001749610E 00,0.10316812330947621682E-01, * 0.63175643771119423041E 00,0.10587167904885197931E-01, * 0.61031811371518640016E 00,0.10849844089337314099E-01, * 0.58836243444766254143E 00,0.11104461134006926537E-01/ DATA * P(337),P(338),P(339),P(340),P(341),P(342),P(343), * P(344),P(345),P(346),P(347),P(348),P(349),P(350), * P(351),P(352),P(353),P(354),P(355),P(356),P(357), * P(358),P(359),P(360),P(361),P(362),P(363),P(364)/ * 0.56590588542365442262E 00,0.11350654315980596602E-01, * 0.54296566649831149049E 00,0.11588074033043952568E-01, * 0.51955966153745702199E 00,0.11816385890830235763E-01, * 0.49570640791876146017E 00,0.12035270785279562630E-01, * 0.47142506587165887693E 00,0.12244424981611985899E-01, * 0.44673538766202847374E 00,0.12443560190714035263E-01, * 0.42165768662616330006E 00,0.12632403643542078765E-01, * 0.39621280605761593918E 00,0.12810698163877361967E-01, * 0.37042208795007823014E 00,0.12978202239537399286E-01, * 0.34430734159943802278E 00,0.13134690091960152836E-01, * 0.31789081206847668318E 00,0.13279951743930530650E-01, * 0.29119514851824668196E 00,0.13413793085110098513E-01, * 0.26424337241092676194E 00,0.13536035934956213614E-01, * 0.23705884558982972721E 00,0.13646518102571291428E-01/ DATA * P(365),P(366),P(367),P(368),P(369),P(370),P(371), * P(372),P(373),P(374),P(375),P(376),P(377),P(378), * P(379),P(380),P(381)/ * 0.20966523824318119477E 00,0.13745093443001896632E-01, * 0.18208649675925219825E 00,0.13831631909506428676E-01, * 0.15434681148137810869E 00,0.13906019601325461264E-01, * 0.12647058437230196685E 00,0.13968158806516938516E-01, * 0.98482396598119202090E-01,0.14017968039456608810E-01, * 0.70406976042855179063E-01,0.14055382072649964277E-01, * 0.42269164765363603212E-01,0.14080351962553661325E-01, * 0.14093886410782462614E-01,0.14092845069160408355E-01, * 0.14094407090096179347E-01/ ICHECK = 0 C CHECK FOR TRIVIAL CASE. IF (A.EQ.B) GO TO 70 C SCALE FACTORS. SUM = (B+A)/2.0 DIFF = (B-A)/2.0 C 1-POINT GAUSS FZERO = F(SUM) RESULT(1) = 2.0*FZERO*DIFF I = 0 IOLD = 0 INEW = 1 K = 2 ACUM = 0.0 GO TO 30 10 IF (K.EQ.8) GO TO 50 K = K + 1 ACUM = 0.0 C CONTRIBUTION FROM FUNCTION VALUES ALREADY COMPUTED. DO 20 J=1,IOLD I = I + 1 ACUM = ACUM + P(I)*FUNCT(J) 20 CONTINUE C CONTRIBUTION FROM NEW FUNCTION VALUES. 30 IOLD = IOLD + INEW DO 40 J=INEW,IOLD I = I + 1 X = P(I)*DIFF FUNCT(J) = F(SUM+X) + F(SUM-X) I = I + 1 ACUM = ACUM + P(I)*FUNCT(J) 40 CONTINUE INEW = IOLD + 1 I = I + 1 RESULT(K) = (ACUM+P(I)*FZERO)*DIFF C CHECK FOR CONVERGENCE. IF (ABS(RESULT(K)-RESULT(K-1))-EPSIL*ABS(RESULT(K))) 60, * 60, 10 C CONVERGENCE NOT ACHIEVED. 50 ICHECK = 1 C NORMAL TERMINATION. 60 NPTS = INEW + IOLD RETURN C TRIVIAL CASE 70 K = 2 RESULT(1) = 0.0 RESULT(2) = 0.0 NPTS = 0 RETURN END SUBROUTINE QAGS (F, A, B, EPSABS, EPSREL, RESULT, ABSERR, * NEVAL, IER, LIMIT, LENW, LAST, IWORK, WORK) C----------------------------------------------------------------------- C C COMPUTATION OF A DEFINITE INTEGRAL C C----------------------------------------------------------------------- C C PURPOSE C THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO A GIVEN C DEFINITE INTEGRAL I = INTEGRAL OF F OVER (A,B), C HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY C ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). C C PARAMETERS C ON ENTRY C F - REAL C FUNCTION SUBPROGRAM DEFINING THE INTEGRAND C FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE C DECLARED E X T E R N A L IN THE DRIVER PROGRAM. C C A - REAL C LOWER LIMIT OF INTEGRATION C C B - REAL C UPPER LIMIT OF INTEGRATION C C EPSABS - REAL C ABSOLUTE ACCURACY REQUESTED C C EPSREL - REAL C RELATIVE ACCURACY REQUESTED C C ON RETURN C RESULT - REAL C APPROXIMATION TO THE INTEGRAL C C ABSERR - REAL C ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR, C WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT) C C NEVAL - INTEGER C NUMBER OF INTEGRAND EVALUATIONS C C IER - INTEGER C IER = 0 NORMAL AND RELIABLE TERMINATION OF THE C ROUTINE. IT IS ASSUMED THAT THE REQUESTED C ACCURACY HAS BEEN ACHIEVED. C IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE C THE ESTIMATES FOR INTEGRAL AND ERROR ARE C LESS RELIABLE. IT IS ASSUMED THAT THE C REQUESTED ACCURACY HAS NOT BEEN ACHIEVED. C C IER = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED C HAS BEEN ACHIEVED. ONE CAN ALLOW MORE SUB- C DIVISIONS BY INCREASING THE VALUE OF C LIMIT (AND TAKING THE ACCORDING C DIMENSION ADJUSTMENTS INTO ACCOUNT). C HOWEVER, IF THIS YIELDS NO IMPROVEMENT C IT IS ADVISED TO ANALYZE THE INTEGRAND C IN ORDER TO DETERMINE THE INTEGRATION C DIFFICULTIES. IF THE POSITION OF A C LOCAL DIFFICULTY CAN BE DETERMINED (E.G. C SINGULARITY, DISCONTINUITY WITHIN THE C INTERVAL) ONE WILL PROBABLY GAIN FROM C SPLITTING UP THE INTERVAL AT THIS POINT C AND CALLING THE INTEGRATOR ON THE SUB- C RANGES. IF POSSIBLE, AN APPROPRIATE C SPECIAL-PURPOSE INTEGRATOR SHOULD BE USED, C WHICH IS DESIGNED FOR HANDLING THE TYPE C OF DIFFICULTY INVOLVED. C = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS DETEC- C TED, WHICH PREVENTS THE REQUESTED C TOLERANCE FROM BEING ACHIEVED. C THE ERROR MAY BE UNDER-ESTIMATED. C = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR C OCCURS AT SOME POINTS OF THE INTEGRATION C INTERVAL. C = 4 THE ALGORITHM DOES NOT CONVERGE. C IT IS PRESUMED THAT THE REQUESTED C TOLERANCE CANNOT BE ACHIEVED, AND THAT THE C RETURNED RESULT IS THE BEST WHICH CAN BE C OBTAINED. C = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR C SLOWLY CONVERGENT. IT MUST BE NOTED C THAT DIVERGENCE CAN OCCUR WITH ANY OTHER C VALUE OF IER. C = 6 THE INPUT IS INVALID BECAUSE EPSABS C OR EPSREL IS NEGATIVE, LIMIT .LT. 1, C OR LENW .LT. 4 * LIMIT. C RESULT, ABSERR, NEVAL, LAST ARE C SET TO ZERO. C C DIMENSIONING PARAMETERS C LIMIT - INTEGER C DIMENSIONING PARAMETER FOR IWORK C LIMIT DETERMINES THE MAXIMUM NUMBER C OF SUBINTERVALS IN THE PARTITION OF THE GIVEN C INTEGRATION INTERVAL (A,B), LIMIT.GE.1. C IF LIMIT.LT.1, THE ROUTINE WILL END WITH C IER = 6. C C LENW - INTEGER C DIMENSIONING PARAMETER FOR WORK C LENW MUST BE AT LEAST LIMIT*4. C IF LENW.LT.LIMIT*4, THE ROUTINE WILL END C WITH IER = 6. C C LAST - INTEGER C ON RETURN, LAST EQUALS THE NUMBER OF C SUBINTERVALS PRODUCED IN THE SUBDIVISION C PROCESS, WHICH DETERMINES THE NUMBER OF C SIGNIFICANT ELEMENTS ACTUALLY IN THE WORK C ARRAYS. C C WORK ARRAYS C IWORK - INTEGER C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST K C ELEMENTS OF WHICH CONTAIN POINTERS C TO THE ERROR ESTIMATES OVER THE SUBINTERVALS C SUCH THAT WORK(LIMIT*3+IWORK(1)),... , C WORK(LIMIT*3+IWORK(K)) FORM A DECREASING C SEQUENCE, WITH K = LAST IF LAST.LE.(LIMIT/2+2), AND C K = LIMIT+1-LAST OTHERWISE C C WORK - REAL C VECTOR OF DIMENSION AT LEAST LENW C ON RETURN C WORK(1), ..., WORK(LAST) CONTAIN THE LEFT C END POINTS OF THE SUBINTERVALS IN THE C PARTITION OF (A,B), C WORK(LIMIT+1), ..., WORK(LIMIT+LAST) CONTAIN C THE RIGHT END POINTS, C WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) C CONTAIN THE INTEGRAL APPROXIMATIONS OVER C THE SUBINTERVALS, C WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST) C CONTAIN THE ERROR ESTIMATES. C C SUBROUTINES OR FUNCTIONS NEEDED C - QAGSE C - QK21F C - QPSRT C - QELG C - F (USER-PROVIDED FUNCTION) C - SPMPAR C C----------------------------------------------------------------------- REAL WORK(LENW) INTEGER IWORK(LIMIT) EXTERNAL F C C CHECK VALIDITY OF LIMIT AND LENW. C IER = 6 NEVAL = 0 LAST = 0 RESULT = 0.0 ABSERR = 0.0 IF (LIMIT .LT. 1 .OR. LENW .LT. LIMIT*4) RETURN C C PREPARE CALL FOR QAGSE. C L1 = LIMIT + 1 L2 = LIMIT + L1 L3 = LIMIT + L2 C CALL QAGSE (F,A,B,EPSABS,EPSREL,LIMIT,RESULT,ABSERR,NEVAL, * IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST) RETURN END SUBROUTINE QAGSE (F,A,B,EPSABS,EPSREL,LIMIT,RESULT,ABSERR, * NEVAL,IER,ALIST,BLIST,RLIST,ELIST,IORD,LAST) C----------------------------------------------------------------------- C C COMPUTATION OF A DEFINITE INTEGRAL C C----------------------------------------------------------------------- C C PURPOSE C THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO A GIVEN C DEFINITE INTEGRAL I = INTEGRAL OF F OVER (A,B), C HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY C ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). C C PARAMETERS C ON ENTRY C F - REAL C FUNCTION SUBPROGRAM DEFINING THE INTEGRAND C FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE C DECLARED E X T E R N A L IN THE DRIVER PROGRAM. C C A - REAL C LOWER LIMIT OF INTEGRATION C C B - REAL C UPPER LIMIT OF INTEGRATION C C EPSABS - REAL C ABSOLUTE ACCURACY REQUESTED C C EPSREL - REAL C RELATIVE ACCURACY REQUESTED C C LIMIT - INTEGER C GIVES AN UPPERBOUND ON THE NUMBER OF C SUBINTERVALS IN THE PARTITION OF (A,B) C C ON RETURN C RESULT - REAL C APPROXIMATION TO THE INTEGRAL C C ABSERR - REAL C ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR, C WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT) C C NEVAL - INTEGER C NUMBER OF INTEGRAND EVALUATIONS C C IER - INTEGER C IER = 0 NORMAL AND RELIABLE TERMINATION OF THE C ROUTINE. IT IS ASSUMED THAT THE REQUESTED C ACCURACY HAS BEEN ACHIEVED. C IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE C THE ESTIMATES FOR INTEGRAL AND ERROR ARE C LESS RELIABLE. IT IS ASSUMED THAT THE C REQUESTED ACCURACY HAS NOT BEEN ACHIEVED. C C = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED C HAS BEEN ACHIEVED. ONE CAN ALLOW MORE SUB- C DIVISIONS BY INCREASING THE VALUE OF C LIMIT (AND TAKING THE ACCORDING C DIMENSION ADJUSTMENTS INTO ACCOUNT). C HOWEVER, IF THIS YIELDS NO IMPROVEMENT C IT IS ADVISED TO ANALYZE THE INTEGRAND C IN ORDER TO DETERMINE THE INTEGRATION C DIFFICULTIES. IF THE POSITION OF A C LOCAL DIFFICULTY CAN BE DETERMINED (E.G. C SINGULARITY, DISCONTINUITY WITHIN THE C INTERVAL) ONE WILL PROBABLY GAIN FROM C SPLITTING UP THE INTERVAL AT THIS POINT C AND CALLING THE INTEGRATOR ON THE SUB- C RANGES. IF POSSIBLE, AN APPROPRIATE C SPECIAL-PURPOSE INTEGRATOR SHOULD BE USED, C WHICH IS DESIGNED FOR HANDLING THE TYPE C OF DIFFICULTY INVOLVED. C = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS DETEC- C TED, WHICH PREVENTS THE REQUESTED C TOLERANCE FROM BEING ACHIEVED. C THE ERROR MAY BE UNDER-ESTIMATED. C = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR C OCCURS AT SOME POINTS OF THE INTEGRATION C INTERVAL. C = 4 THE ALGORITHM DOES NOT CONVERGE. C IT IS PRESUMED THAT THE REQUESTED C TOLERANCE CANNOT BE ACHIEVED, AND THAT THE C RETURNED RESULT IS THE BEST WHICH CAN BE C OBTAINED. C = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR C SLOWLY CONVERGENT. IT MUST BE NOTED C THAT DIVERGENCE CAN OCCUR WITH ANY OTHER C VALUE OF IER. C = 6 THE INPUT IS INVALID BECAUSE EPSABS C OR EPSREL IS NEGATIVE. C RESULT, ABSERR, NEVAL, LAST, RLIST(1), C IORD(1) AND ELIST(1) ARE SET TO ZERO. C ALIST(1) AND BLIST(1) ARE SET TO A AND B C RESPECTIVELY. C C ALIST - REAL C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST C LAST ELEMENTS OF WHICH ARE THE LEFT C END POINTS OF THE SUBINTERVALS IN THE PARTITION C OF THE GIVEN INTEGRATION RANGE (A,B) C C BLIST - REAL C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST C LAST ELEMENTS OF WHICH ARE THE RIGHT C END POINTS OF THE SUBINTERVALS IN THE PARTITION C OF THE GIVEN INTEGRATION RANGE (A,B) C C RLIST - REAL C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST C LAST ELEMENTS OF WHICH ARE THE INTEGRAL C APPROXIMATIONS ON THE SUBINTERVALS C C ELIST - REAL C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST C LAST ELEMENTS OF WHICH ARE THE MODULI C OF THE ABSOLUTE ERROR ESTIMATES ON THE C SUBINERVALS C C IORD - INTEGER C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST K C ELEMENTS OF WHICH ARE POINTERS TO THE ERROR C ESTIMATES OVER THE SUBINTERVALS, SUCH C THAT ELIST(IORD(1)), ..., ELIST(IORD(K)) C FORM A DECREASING SEQUENCE, WITH K = LAST C IF LAST.LE.(LIMIT/2+2), AND K = LIMIT+1-LAST C OTHERWISE C C LAST - INTEGER C NUMBER OF SUBINTERVALS ACTUALLY PRODUCED IN THE C SUBDIVISION PROCESS C C SUBROUTINES OR FUNCTIONS NEEDED C - QK21F C - QPSRT C - QELG C - F (USER-PROVIDED FUNCTION) C - SPMPAR C C----------------------------------------------------------------------- REAL A,ABSEPS,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1,A2, * B,BLIST,B1,B2,CORREC,DEFABS,DEFAB1,DEFAB2,DRES,ELIST, * EPMACH,EPSABS,EPSREL,ERLARG,ERLAST,ERRBND,ERRMAX, * ERROR1,ERROR2,ERRO12,ERRSUM,ERTEST,F,OFLOW,RERR,RESABS, * RESEPS,RESULT,RES3LA,RLIST,RLIST2,SMALL,SPMPAR,T,UFLOW INTEGER ID,IER,IERRO,IORD,IROFF1,IROFF2,IROFF3,JUPBND,K,KSGN, * KTMIN,LAST,LIMIT,MAXERR,NEVAL,NRES,NRMAX,NUMRL2 LOGICAL EXTRAP,NOEXT C DIMENSION ALIST(LIMIT),BLIST(LIMIT),ELIST(LIMIT),IORD(LIMIT), * RES3LA(3),RLIST(LIMIT),RLIST2(52) C EXTERNAL F C C THE DIMENSION OF RLIST2 IS DETERMINED BY THE VALUE OF C LIMEXP IN SUBROUTINE QELG (RLIST2 SHOULD BE OF DIMENSION C (LIMEXP+2) AT LEAST). C C LIST OF MAJOR VARIABLES C ----------------------- C C ALIST - LIST OF LEFT END POINTS OF ALL SUBINTERVALS C CONSIDERED UP TO NOW C BLIST - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS C CONSIDERED UP TO NOW C RLIST(I) - APPROXIMATION TO THE INTEGRAL OVER C (ALIST(I),BLIST(I)) C RLIST2 - ARRAY OF DIMENSION AT LEAST LIMEXP+2 C CONTAINING THE PART OF THE EPSILON TABLE C WHICH IS STILL NEEDED FOR FURTHER COMPUTATIONS C ELIST(I) - ERROR ESTIMATE APPLYING TO RLIST(I) C MAXERR - POINTER TO THE INTERVAL WITH LARGEST ERROR C ESTIMATE C ERRMAX - ELIST(MAXERR) C ERLAST - ERROR ON THE INTERVAL CURRENTLY SUBDIVIDED C (BEFORE THAT SUBDIVISION HAS TAKEN PLACE) C AREA - SUM OF THE INTEGRALS OVER THE SUBINTERVALS C ERRSUM - SUM OF THE ERRORS OVER THE SUBINTERVALS C ERRBND - REQUESTED ACCURACY MAX(EPSABS,EPSREL* C ABS(RESULT)) C *****1 - VARIABLE FOR THE LEFT INTERVAL C *****2 - VARIABLE FOR THE RIGHT INTERVAL C LAST - INDEX FOR SUBDIVISION C NRES - NUMBER OF CALLS TO THE EXTRAPOLATION ROUTINE C NUMRL2 - NUMBER OF ELEMENTS CURRENTLY IN RLIST2. IF AN C APPROPRIATE APPROXIMATION TO THE COMPOUNDED C INTEGRAL HAS BEEN OBTAINED IT IS PUT IN C RLIST2(NUMRL2) AFTER NUMRL2 HAS BEEN INCREASED C BY ONE. C SMALL - LENGTH OF THE SMALLEST INTERVAL CONSIDERED C UP TO NOW, MULTIPLIED BY 1.5 C ERLARG - SUM OF THE ERRORS OVER THE INTERVALS LARGER C THAN THE SMALLEST INTERVAL CONSIDERED UP TO NOW C EXTRAP - LOGICAL VARIABLE DENOTING THAT THE ROUTINE C IS ATTEMPTING TO PERFORM EXTRAPOLATION C I.E. BEFORE SUBDIVIDING THE SMALLEST INTERVAL C WE TRY TO DECREASE THE VALUE OF ERLARG. C NOEXT - LOGICAL VARIABLE DENOTING THAT EXTRAPOLATION C IS NO LONGER ALLOWED (TRUE VALUE) C C MACHINE DEPENDENT CONSTANTS C --------------------------- C C EPMACH IS THE LARGEST RELATIVE SPACING. C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. C OFLOW IS THE LARGEST POSITIVE MAGNITUDE. C EPMACH = SPMPAR(1) UFLOW = SPMPAR(2) OFLOW = SPMPAR(3) C C CHECK EPSABS AND EPSREL C ----------------------- C NEVAL = 0 LAST = 0 RESULT = 0.0 ABSERR = 0.0 ALIST(1) = A BLIST(1) = B RLIST(1) = 0.0 ELIST(1) = 0.0 IER = 6 IF (EPSABS .LT. 0.0 .OR. EPSREL .LT. 0.0) GO TO 999 IER = 0 RERR = AMAX1(EPSREL, 50.0*EPMACH, 0.5E-14) C C FIRST APPROXIMATION TO THE INTEGRAL C ----------------------------------- C IERRO = 0 CALL QK21F (F, A, B, RESULT, ABSERR, DEFABS, RESABS, * EPMACH, UFLOW, ID) IF (ID .NE. 0) GO TO 999 NEVAL = 21 C C TEST ON ACCURACY. C DRES = ABS(RESULT) ERRBND = AMAX1(EPSABS,RERR*DRES) LAST = 1 RLIST(1) = RESULT ELIST(1) = ABSERR IORD(1) = 1 IF (ABSERR .LE. 100.0*EPMACH*DEFABS .AND. ABSERR .GT. * ERRBND) IER = 2 IF (LIMIT .EQ. 1) IER = 1 IF (IER .NE. 0) GO TO 999 C C INITIALIZATION C -------------- C RLIST2(1) = RESULT ERRMAX = ABSERR MAXERR = 1 AREA = RESULT ERRSUM = ABSERR ABSERR = OFLOW CORREC = 0.0 NRMAX = 1 NRES = 0 NUMRL2 = 2 KTMIN = 0 EXTRAP = .FALSE. NOEXT = .FALSE. IROFF1 = 0 IROFF2 = 0 IROFF3 = 0 KSGN = -1 IF (DRES .GE. (1.0 - 50.0*EPMACH)*DEFABS) KSGN = 1 T = 1.0 + 100.0*EPMACH C C MAIN DO-LOOP C ------------ C DO 90 LAST = 2,LIMIT C C BISECT THE SUBINTERVAL WITH THE NRMAX-TH LARGEST C ERROR ESTIMATE. C A1 = ALIST(MAXERR) B1 = 0.5*(ALIST(MAXERR) + BLIST(MAXERR)) A2 = B1 B2 = BLIST(MAXERR) ERLAST = ERRMAX CALL QK21F (F, A1, B1, AREA1, ERROR1, RESABS, DEFAB1, * EPMACH, UFLOW, IER) IF (IER .NE. 0) GO TO 100 CALL QK21F (F, A2, B2, AREA2, ERROR2, RESABS, DEFAB2, * EPMACH, UFLOW, IER) NEVAL = NEVAL + 42 C C IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL C AND ERROR AND TEST FOR ACCURACY. C AREA12 = AREA1 + AREA2 ERRO12 = ERROR1 + ERROR2 ERRSUM = ERRSUM + ERRO12 - ERRMAX AREA = AREA + AREA12 - RLIST(MAXERR) IF (DEFAB1 .EQ. ERROR1 .OR. DEFAB2 .EQ. ERROR2) GO TO 15 IF (ABS(RLIST(MAXERR) - AREA12) .GT. 0.1E-04*ABS(AREA12) * .OR. ERRO12 .LT. 0.99*ERRMAX) GO TO 10 IF (EXTRAP) IROFF2 = IROFF2 + 1 IF (.NOT.EXTRAP) IROFF1 = IROFF1 + 1 10 IF (LAST .GT. 10 .AND. ERRO12 .GT. ERRMAX) IROFF3 = IROFF3 + 1 15 RLIST(MAXERR) = AREA1 RLIST(LAST) = AREA2 ERRBND = AMAX1(EPSABS,RERR*ABS(AREA)) C C TEST FOR ROUNDOFF ERROR AND EVENTUALLY C SET ERROR FLAG. C IF (IROFF1 + IROFF2 .GE. 10 .OR. IROFF3 .GE. 20) IER = 2 IF (IROFF2 .GE. 5) IERRO = 3 C C SET ERROR FLAG IN THE CASE THAT THE NUMBER OF C SUBINTERVALS EQUALS LIMIT. C IF (LAST .EQ. LIMIT) IER = 1 C C SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR C AT A POINT OF THE INTEGRATION RANGE. C IF (AMAX1(ABS(A1),ABS(B2)) .LE. * T*(ABS(A2) + 0.1E+04*UFLOW)) IER = 4 C C APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. C IF (ERROR2 .GT. ERROR1) GO TO 20 ALIST(LAST) = A2 BLIST(MAXERR) = B1 BLIST(LAST) = B2 ELIST(MAXERR) = ERROR1 ELIST(LAST) = ERROR2 GO TO 30 20 ALIST(MAXERR) = A2 ALIST(LAST) = A1 BLIST(LAST) = B1 RLIST(MAXERR) = AREA2 RLIST(LAST) = AREA1 ELIST(MAXERR) = ERROR2 ELIST(LAST) = ERROR1 C C CALL SUBROUTINE QPSRT TO MAINTAIN THE DESCENDING ORDERING C IN THE LIST OF ERROR ESTIMATES AND SELECT THE C SUBINTERVAL WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE C BISECTED NEXT). C 30 CALL QPSRT (LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX) C ***JUMP OUT OF DO-LOOP IF (ERRSUM .LE. ERRBND) GO TO 115 C ***JUMP OUT OF DO-LOOP IF (IER .NE. 0) GO TO 100 IF (LAST .EQ. 2) GO TO 80 IF (NOEXT) GO TO 90 ERLARG = ERLARG - ERLAST IF (ABS(B1 - A1) .GT. SMALL) ERLARG = ERLARG + ERRO12 IF (EXTRAP) GO TO 40 C C TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE C SMALLEST INTERVAL. C IF (ABS(BLIST(MAXERR) - ALIST(MAXERR)) .GT. SMALL) GO TO 90 EXTRAP = .TRUE. NRMAX = 2 40 IF (IERRO .EQ. 3 .OR. ERLARG .LE. ERTEST) GO TO 60 C C THE SMALLEST INTERVAL HAS THE LARGEST ERROR. C BEFORE BISECTING DECREASE THE SUM OF THE ERRORS C OVER THE LARGER INTERVALS (ERLARG) AND PERFORM C EXTRAPOLATION. C ID = NRMAX JUPBND = LAST IF (LAST .GT. (2 + LIMIT/2)) JUPBND = LIMIT + 3 - LAST DO 50 K = ID,JUPBND MAXERR = IORD(NRMAX) ERRMAX = ELIST(MAXERR) C ***JUMP OUT OF DO-LOOP IF (ABS(BLIST(MAXERR) - ALIST(MAXERR)) .GT. SMALL) GO TO 90 NRMAX = NRMAX + 1 50 CONTINUE C C PERFORM EXTRAPOLATION. C 60 NUMRL2 = NUMRL2 + 1 RLIST2(NUMRL2) = AREA CALL QELG (NUMRL2, RLIST2, RESEPS, ABSEPS, RES3LA, NRES, * EPMACH, OFLOW) KTMIN = KTMIN + 1 IF (KTMIN .GT. 5 .AND. ABSERR .LT. 0.1E-02*ERRSUM) IER = 5 IF (ABSEPS .GE. ABSERR) GO TO 70 KTMIN = 0 ABSERR = ABSEPS RESULT = RESEPS CORREC = ERLARG ERTEST = AMAX1(EPSABS,RERR*ABS(RESEPS)) C ***JUMP OUT OF DO-LOOP IF (ABSERR .LE. ERTEST) GO TO 100 C C PREPARE BISECTION OF THE SMALLEST INTERVAL. C 70 IF (NUMRL2 .EQ. 1) NOEXT = .TRUE. IF (IER .EQ. 5) GO TO 100 MAXERR = IORD(1) ERRMAX = ELIST(MAXERR) NRMAX = 1 EXTRAP = .FALSE. SMALL = SMALL*0.5 ERLARG = ERRSUM GO TO 90 80 SMALL = ABS(B - A)*0.375 ERLARG = ERRSUM ERTEST = ERRBND RLIST2(2) = AREA 90 CONTINUE C C SET FINAL RESULT AND ERROR ESTIMATE. C ------------------------------------ C 100 IF (ABSERR .EQ. OFLOW) GO TO 115 IF (IER + IERRO .EQ. 0) GO TO 110 IF (IERRO .EQ. 3) ABSERR = ABSERR + CORREC IF (IER .EQ. 0) IER = 3 IF (RESULT .NE. 0.0 .AND. AREA .NE. 0.0) GO TO 105 IF (ABSERR .GT. ERRSUM) GO TO 115 IF (AREA .EQ. 0.0) GO TO 130 GO TO 110 105 IF (ABSERR/ABS(RESULT) .GT. ERRSUM/ABS(AREA)) GO TO 115 C C TEST ON DIVERGENCE. C 110 IF (KSGN .EQ. -1 .AND. AMAX1(ABS(RESULT),ABS(AREA)) .LE. * DEFABS*0.1E-01) GO TO 130 IF (0.1E-01 .GT. (RESULT/AREA) .OR. (RESULT/AREA) .GT. 0.1E+03 * .OR. ERRSUM .GT. ABS(AREA)) IER = 6 GO TO 130 C C COMPUTE GLOBAL INTEGRAL SUM. C 115 RESULT = 0.0 DO 120 K = 1,LAST RESULT = RESULT + RLIST(K) 120 CONTINUE ABSERR = ERRSUM 130 IF (IER .GT. 2) IER = IER - 1 999 RETURN END SUBROUTINE QK21F (F, A, B, RESULT, ABSERR, RESABS, RESASC, * EPMACH, UFLOW, ISIG) C----------------------------------------------------------------------- C C 1. PURPOSE C TO COMPUTE I = INTEGRAL OF F OVER (A,B), WITH ERROR C ESTIMATE C J = INTEGRAL OF ABS(F) OVER (A,B) C C 2. PARAMETERS C ON ENTRY C F - REAL C FUNCTION SUBPROGRAM DEFINING THE INTEGRAND C FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS C TO BE DECLARED E X T E R N A L IN THE C CALLING PROGRAM. C C A - REAL C LOWER LIMIT OF INTEGRATION C C B - REAL C UPPER LIMIT OF INTEGRATION C C EPMACH - REAL C THE RELATIVE PRECISION OF THE FLOATING C ARITHMETIC BEING USED. C C UFLOW - REAL C THE SMALLEST POSITIVE MAGNITUDE. C C ON RETURN C RESULT - REAL C APPROXIMATION TO THE INTEGRAL I C RESULT IS COMPUTED BY APPLYING THE 21-POINT C KRONROD RULE (RESK) OBTAINED BY OPTIMAL C ADDITION OF ABSCISSAE TO THE 10-POINT GAUSS C RULE (RESG). C C ABSERR - REAL C ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR, C WHICH SHOULD NOT EXCEED ABS(I-RESULT) C C RESABS - REAL C APPROXIMATION TO THE INTEGRAL J C C RESASC - REAL C APPROXIMATION TO THE INTEGRAL OF ABS(F-I/(B-A)) C OVER (A,B) C C ISIG - INTEGER C ISIG=0 THE INTEGRAL WAS APPROXIMATED. C ISIG=5 THE INTERVAL (A,B) IS TOO SHORT. C THE INTEGRAL CANNOT BE COMPUTED. C C 3. SUBROUTINES OR FUNCTIONS NEEDED C - F (USER-PROVIDED FUNCTION) C C----------------------------------------------------------------------- REAL FV1(10), FV2(10), WG(5), WGK(11), XGK(11) EXTERNAL F C C THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE INTERVAL (-1,1). C BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND THEIR C CORRESPONDING WEIGHTS ARE GIVEN. C C XGK - ABSCISSAE OF THE 21-POINT KRONROD RULE C XGK(2), XGK(4), ... ABSCISSAE OF THE 10-POINT C GAUSS RULE C XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY C ADDED TO THE 10-POINT GAUSS RULE C C WGK - WEIGHTS OF THE 21-POINT KRONROD RULE C C WG - WEIGHTS OF THE 10-POINT GAUSS RULE C DATA XGK(1),XGK(2),XGK(3),XGK(4),XGK(5),XGK(6),XGK(7), * XGK(8),XGK(9),XGK(10),XGK(11)/ * 0.9956571630258081E+00, 0.9739065285171717E+00, * 0.9301574913557082E+00, 0.8650633666889845E+00, * 0.7808177265864169E+00, 0.6794095682990244E+00, * 0.5627571346686047E+00, 0.4333953941292472E+00, * 0.2943928627014602E+00, 0.1488743389816312E+00, * 0.0000000000000000E+00/ C DATA WGK(1),WGK(2),WGK(3),WGK(4),WGK(5),WGK(6),WGK(7), * WGK(8),WGK(9),WGK(10),WGK(11)/ * 0.1169463886737187E-01, 0.3255816230796473E-01, * 0.5475589657435200E-01, 0.7503967481091995E-01, * 0.9312545458369761E-01, 0.1093871588022976E+00, * 0.1234919762620659E+00, 0.1347092173114733E+00, * 0.1427759385770601E+00, 0.1477391049013385E+00, * 0.1494455540029169E+00/ C DATA WG(1),WG(2),WG(3),WG(4),WG(5)/ * 0.6667134430868814E-01, 0.1494513491505806E+00, * 0.2190863625159820E+00, 0.2692667193099964E+00, * 0.2955242247147529E+00/ C C C LIST OF MAJOR VARIABLES C ----------------------- C C CENTR - MID POINT OF THE INTERVAL C HLGTH - HALF-LENGTH OF THE INTERVAL C ABSC - ABSCISSA C FVAL* - FUNCTION VALUE C RESG - RESULT OF THE 10-POINT GAUSS FORMULA C RESK - RESULT OF THE 21-POINT KRONROD FORMULA C RESKH - APPROXIMATION TO THE MEAN VALUE OF F OVER (A,B), C I.E. TO I/(B-A) C C CENTR = 0.5*(A + B) HLGTH = 0.5*(B - A) DHLGTH = ABS(HLGTH) C C CHECK IF THE INTERVAL (A,B) IS TOO SHORT C ISIG = 5 ABSC = ABS(CENTR) + DHLGTH*0.14 IF (ABSC .EQ. ABS(CENTR)) RETURN C C COMPUTE THE 21-POINT KRONROD APPROXIMATION TO C THE INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR. C ISIG = 0 RESG = 0.0 FC = F(CENTR) RESK = WGK(11)*FC RESABS = ABS(RESK) DO 10 J = 1,5 JTW = 2*J ABSC = HLGTH*XGK(JTW) FVAL1 = F(CENTR - ABSC) FVAL2 = F(CENTR + ABSC) FV1(JTW) = FVAL1 FV2(JTW) = FVAL2 FSUM = FVAL1 + FVAL2 RESG = RESG + WG(J)*FSUM RESK = RESK + WGK(JTW)*FSUM RESABS = RESABS + WGK(JTW)*(ABS(FVAL1) + ABS(FVAL2)) 10 CONTINUE DO 15 J = 1,5 JTWM1 = 2*J - 1 ABSC = HLGTH*XGK(JTWM1) FVAL1 = F(CENTR - ABSC) FVAL2 = F(CENTR + ABSC) FV1(JTWM1) = FVAL1 FV2(JTWM1) = FVAL2 FSUM = FVAL1 + FVAL2 RESK = RESK + WGK(JTWM1)*FSUM RESABS = RESABS + WGK(JTWM1)*(ABS(FVAL1) + ABS(FVAL2)) 15 CONTINUE RESKH = RESK*0.5 RESASC = WGK(11)*ABS(FC - RESKH) DO 20 J = 1,10 RESASC = RESASC + WGK(J)*(ABS(FV1(J)-RESKH) + ABS(FV2(J)-RESKH)) 20 CONTINUE RESULT = RESK*HLGTH RESABS = RESABS*DHLGTH RESASC = RESASC*DHLGTH ABSERR = ABS((RESK - RESG)*HLGTH) IF (RESASC .NE. 0.0 .AND. ABSERR .NE. 0.0) * ABSERR = RESASC*AMIN1(1.0, * (0.2E+03*ABSERR/RESASC)**1.5) TOL = EPMACH*0.5E+02 IF (RESABS .GT. UFLOW/TOL) ABSERR = AMAX1(ABSERR,TOL*RESABS) RETURN END SUBROUTINE QAGI (F, BOUND, INF, EPSABS, EPSREL, RESULT, ABSERR, * NEVAL, IER, LIMIT, LENW, LAST, IWORK, WORK) C----------------------------------------------------------------------- C C INTEGRATION OVER INFINITE INTERVALS C C----------------------------------------------------------------------- C C PURPOSE C THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO A GIVEN C INTEGRAL I = INTEGRAL OF F OVER (BOUND,+INFINITY) C OR I = INTEGRAL OF F OVER (-INFINITY,BOUND) C OR I = INTEGRAL OF F OVER (-INFINITY,+INFINITY), C HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY C ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). C C PARAMETERS C ON ENTRY C F - REAL C FUNCTION SUBPROGRAM DEFINING THE INTEGRAND C FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE C DECLARED E X T E R N A L IN THE DRIVER PROGRAM. C C BOUND - REAL C FINITE BOUND OF INTEGRATION RANGE C (HAS NO MEANING IF INTERVAL IS DOUBLY-INFINITE) C C INF - INTEGER C INDICATING THE KIND OF INTEGRATION RANGE C INVOLVED C INF = 1 CORRESPONDS TO (BOUND,+INFINITY), C INF = -1 TO (-INFINITY,BOUND), C INF = 2 TO (-INFINITY,+INFINITY). C C EPSABS - REAL C ABSOLUTE ACCURACY REQUESTED C C EPSREL - REAL C RELATIVE ACCURACY REQUESTED C C ON RETURN C RESULT - REAL C APPROXIMATION TO THE INTEGRAL C C ABSERR - REAL C ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR, C WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT) C C NEVAL - INTEGER C NUMBER OF INTEGRAND EVALUATIONS C C IER - INTEGER C IER = 0 NORMAL AND RELIABLE TERMINATION OF THE C ROUTINE. IT IS ASSUMED THAT THE REQUESTED C ACCURACY HAS BEEN ACHIEVED. C - IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE. THE C ESTIMATES FOR RESULT AND ERROR ARE LESS C RELIABLE. IT IS ASSUMED THAT THE REQUESTED C ACCURACY HAS NOT BEEN ACHIEVED. C C IER = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED C HAS BEEN ACHIEVED. ONE CAN ALLOW MORE C SUBDIVISIONS BY INCREASING THE VALUE C OF LIMIT (AND TAKING THE ACCORDING C DIMENSION ADJUSTMENTS INTO ACCOUNT). C HOWEVER, IF THIS YIELDS NO IMPROVEMENT C IT IS ADVISED TO ANALYZE THE INTEGRAND C IN ORDER TO DETERMINE THE INTEGRATION C DIFFICULTIES. IF THE POSITION OF A LOCAL C DIFFICULTY CAN BE DETERMINED (E.G. C SINGULARITY, DISCONTINUITY WITHIN THE C INTERVAL) ONE WILL PROBABLY GAIN FROM C SPLITTING UP THE INTERVAL AT THIS POINT C AND CALLING THE INTEGRATOR ON THE C SUBRANGES. IF POSSIBLE, AN APPROPRIATE C SPECIAL-PURPOSE INTEGRATOR SHOULD BE USED, C WHICH IS DESIGNED FOR HANDLING THE TYPE C OF DIFFICULTY INVOLVED. C = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS C DETECTED, WHICH PREVENTS THE REQUESTED C TOLERANCE FROM BEING ACHIEVED. C THE ERROR MAY BE UNDER-ESTIMATED. C = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR OCCURS C AT SOME POINTS OF THE INTEGRATION C INTERVAL. C = 4 THE ALGORITHM DOES NOT CONVERGE. C ROUNDOFF ERROR IS DETECTED IN THE C EXTRAPOLATION TABLE. C IT IS ASSUMED THAT THE REQUESTED TOLERANCE C CANNOT BE ACHIEVED, AND THAT THE RETURNED C RESULT IS THE BEST WHICH CAN BE OBTAINED. C = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR C SLOWLY CONVERGENT. IT MUST BE NOTED THAT C DIVERGENCE CAN OCCUR WITH ANY OTHER VALUE C OF IER. C = 6 THE INPUT IS INVALID BECAUSE EPSABS C OR EPSREL IS NEGATIVE, LIMIT .LT. 1, C OR LENW .LT. 4 * LIMIT. C RESULT, ABSERR, NEVAL, LAST ARE C SET TO ZERO. C C DIMENSIONING PARAMETERS C LIMIT - INTEGER C DIMENSIONING PARAMETER FOR IWORK C LIMIT DETERMINES THE MAXIMUM NUMBER C OF SUBINTERVALS IN THE PARTITION OF THE GIVEN C INTEGRATION INTERVAL (A,B), LIMIT.GE.1. C IF LIMIT.LT.1, THE ROUTINE WILL END WITH C IER = 6. C C LENW - INTEGER C DIMENSIONING PARAMETER FOR WORK C LENW MUST BE AT LEAST LIMIT*4. C IF LENW.LT.LIMIT*4, THE ROUTINE WILL END C WITH IER = 6. C C LAST - INTEGER C ON RETURN, LAST EQUALS THE NUMBER OF C SUBINTERVALS PRODUCED IN THE SUBDIVISION C PROCESS, WHICH DETERMINES THE NUMBER OF SIGNIFICANT C ELEMENTS ACTUALLY IN THE WORK ARRAYS. C C WORK ARRAYS C IWORK - INTEGER C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST C K ELEMENTS OF WHICH CONTAIN POINTERS C TO THE ERROR ESTIMATES OVER THE SUBINTERVALS, C SUCH THAT WORK(LIMIT*3+IWORK(1)),... , C WORK(LIMIT*3+IWORK(K)) FORM A DECREASING C SEQUENCE, WITH K = LAST IF LAST.LE.(LIMIT/2+2), AND C K = LIMIT+1-LAST OTHERWISE C C WORK - REAL C VECTOR OF DIMENSION AT LEAST LENW C ON RETURN C WORK(1), ..., WORK(LAST) CONTAIN THE LEFT C END POINTS OF THE SUBINTERVALS IN THE C PARTITION OF (A,B), C WORK(LIMIT+1), ..., WORK(LIMIT+LAST) CONTAIN C THE RIGHT END POINTS, C WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) C CONTAIN THE INTEGRAL APPROXIMATIONS OVER C THE SUBINTERVALS, C WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST) C CONTAIN THE ERROR ESTIMATES. C C SUBROUTINES OR FUNCTIONS NEEDED C - QAGIE C - QK15I C - QPSRT C - QELG C - F (USER PROVIDED FUNCTION) C - SPMPAR C C----------------------------------------------------------------------- REAL WORK(LENW) INTEGER IWORK(LIMIT) EXTERNAL F C C CHECK VALIDITY OF LIMIT AND LENW. C IER = 6 NEVAL = 0 LAST = 0 RESULT = 0.0 ABSERR = 0.0 IF (LIMIT .LT. 1 .OR. LENW .LT. LIMIT*4) RETURN C C PREPARE CALL FOR QAGIE. C L1 = LIMIT + 1 L2 = LIMIT + L1 L3 = LIMIT + L2 C CALL QAGIE (F,BOUND,INF,EPSABS,EPSREL,LIMIT,RESULT,ABSERR, * NEVAL,IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST) RETURN END SUBROUTINE QAGIE (F,BOUND,INF,EPSABS,EPSREL,LIMIT,RESULT,ABSERR, * NEVAL,IER,ALIST,BLIST,RLIST,ELIST,IORD,LAST) C----------------------------------------------------------------------- C C INTEGRATION OVER INFINITE INTERVALS C C----------------------------------------------------------------------- C C PURPOSE C THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO A GIVEN C INTEGRAL I = INTEGRAL OF F OVER (BOUND,+INFINITY) C OR I = INTEGRAL OF F OVER (-INFINITY,BOUND) C OR I = INTEGRAL OF F OVER (-INFINITY,+INFINITY), C HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY C ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). C C PARAMETERS C ON ENTRY C F - REAL C FUNCTION SUBPROGRAM DEFINING THE INTEGRAND C FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE C DECLARED E X T E R N A L IN THE DRIVER PROGRAM. C C BOUND - REAL C FINITE BOUND OF INTEGRATION RANGE C (HAS NO MEANING IF INTERVAL IS DOUBLY-INFINITE) C C INF - INTEGER C INDICATING THE KIND OF INTEGRATION RANGE C INVOLVED C INF = 1 CORRESPONDS TO (BOUND,+INFINITY), C INF = -1 TO (-INFINITY,BOUND), C INF = 2 TO (-INFINITY,+INFINITY). C C EPSABS - REAL C ABSOLUTE ACCURACY REQUESTED C C EPSREL - REAL C RELATIVE ACCURACY REQUESTED C C LIMIT - INTEGER C GIVES AN UPPER BOUND ON THE NUMBER OF C SUBINTERVALS IN THE PARTITION OF (A,B), C LIMIT.GE.1 C C ON RETURN C RESULT - REAL C APPROXIMATION TO THE INTEGRAL C C ABSERR - REAL C ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR, C WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT) C C NEVAL - INTEGER C NUMBER OF INTEGRAND EVALUATIONS C C IER - INTEGER C IER = 0 NORMAL AND RELIABLE TERMINATION OF THE C ROUTINE. IT IS ASSUMED THAT THE REQUESTED C ACCURACY HAS BEEN ACHIEVED. C - IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE. THE C ESTIMATES FOR RESULT AND ERROR ARE LESS C RELIABLE. IT IS ASSUMED THAT THE REQUESTED C ACCURACY HAS NOT BEEN ACHIEVED. C C IER = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED C HAS BEEN ACHIEVED. ONE CAN ALLOW MORE C SUBDIVISIONS BY INCREASING THE VALUE C OF LIMIT (AND TAKING THE ACCORDING C DIMENSION ADJUSTMENTS INTO ACCOUNT). C HOWEVER, IF THIS YIELDS NO IMPROVEMENT C IT IS ADVISED TO ANALYZE THE INTEGRAND C IN ORDER TO DETERMINE THE INTEGRATION C DIFFICULTIES. IF THE POSITION OF A LOCAL C DIFFICULTY CAN BE DETERMINED (E.G. C SINGULARITY, DISCONTINUITY WITHIN THE C INTERVAL) ONE WILL PROBABLY GAIN FROM C SPLITTING UP THE INTERVAL AT THIS POINT C AND CALLING THE INTEGRATOR ON THE C SUBRANGES. IF POSSIBLE, AN APPROPRIATE C SPECIAL-PURPOSE INTEGRATOR SHOULD BE USED, C WHICH IS DESIGNED FOR HANDLING THE TYPE C OF DIFFICULTY INVOLVED. C = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS C DETECTED, WHICH PREVENTS THE REQUESTED C TOLERANCE FROM BEING ACHIEVED. C THE ERROR MAY BE UNDER-ESTIMATED. C = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR OCCURS C AT SOME POINTS OF THE INTEGRATION C INTERVAL. C = 4 THE ALGORITHM DOES NOT CONVERGE. C ROUNDOFF ERROR IS DETECTED IN THE C EXTRAPOLATION TABLE. C IT IS ASSUMED THAT THE REQUESTED TOLERANCE C CANNOT BE ACHIEVED, AND THAT THE RETURNED C RESULT IS THE BEST WHICH CAN BE OBTAINED. C = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR C SLOWLY CONVERGENT. IT MUST BE NOTED THAT C DIVERGENCE CAN OCCUR WITH ANY OTHER VALUE C OF IER. C = 6 THE INPUT IS INVALID BECAUSE EPSABS C OR EPSREL IS NEGATIVE. C RESULT, ABSERR, NEVAL, LAST, RLIST(1), C ELIST(1) AND IORD(1) ARE SET TO ZERO. C ALIST(1) AND BLIST(1) ARE SET TO 0 C AND 1 RESPECTIVELY. C C ALIST - REAL C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST C LAST ELEMENTS OF WHICH ARE THE LEFT C END POINTS OF THE SUBINTERVALS IN THE PARTITION C OF THE TRANSFORMED INTEGRATION RANGE (0,1). C C BLIST - REAL C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST C LAST ELEMENTS OF WHICH ARE THE RIGHT C END POINTS OF THE SUBINTERVALS IN THE PARTITION C OF THE TRANSFORMED INTEGRATION RANGE (0,1). C C RLIST - REAL C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST C LAST ELEMENTS OF WHICH ARE THE INTEGRAL C APPROXIMATIONS ON THE SUBINTERVALS C C ELIST - REAL C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST C LAST ELEMENTS OF WHICH ARE THE MODULI C OF THE ABSOLUTE ERROR ESTIMATES ON THE C SUBINTERVALS C C IORD - INTEGER C VECTOR OF DIMENSION LIMIT, THE FIRST K C ELEMENTS OF WHICH ARE POINTERS TO THE C ERROR ESTIMATES OVER THE SUBINTERVALS, C SUCH THAT ELIST(IORD(1)), ..., ELIST(IORD(K)) C FORM A DECREASING SEQUENCE, WITH K = LAST C IF LAST.LE.(LIMIT/2+2), AND K = LIMIT+1-LAST C OTHERWISE C C LAST - INTEGER C NUMBER OF SUBINTERVALS ACTUALLY PRODUCED C IN THE SUBDIVISION PROCESS C C SUBROUTINES OR FUNCTIONS NEEDED C - QK15I C - QPSRT C - QELG C - F (USER-PROVIDED FUNCTION) C - SPMPAR C C----------------------------------------------------------------------- REAL ABSEPS,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1,A2, * BLIST,BOUN,BOUND,B1,B2,CORREC,DEFABS,DEFAB1,DEFAB2,DRES, * ELIST,EPMACH,EPSABS,EPSREL,ERLARG,ERLAST,ERRBND,ERRMAX, * ERROR1,ERROR2,ERRO12,ERRSUM,ERTEST,F,OFLOW,RERR,RESABS, * RESEPS,RESULT,RES3LA,RLIST,RLIST2,SMALL,SPMPAR,T,UFLOW INTEGER ID,IER,IERRO,INF,IORD,IROFF1,IROFF2,IROFF3,JUPBND,K,KSGN, * KTMIN,LAST,LIMIT,MAXERR,NEVAL,NRES,NRMAX,NUMRL2 LOGICAL EXTRAP,NOEXT C DIMENSION ALIST(LIMIT),BLIST(LIMIT),ELIST(LIMIT),IORD(LIMIT), * RES3LA(3),RLIST(LIMIT),RLIST2(52) C EXTERNAL F C C THE DIMENSION OF RLIST2 IS DETERMINED BY THE VALUE OF C LIMEXP IN SUBROUTINE QELG. C C C LIST OF MAJOR VARIABLES C ----------------------- C C ALIST - LIST OF LEFT END POINTS OF ALL SUBINTERVALS C CONSIDERED UP TO NOW C BLIST - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS C CONSIDERED UP TO NOW C RLIST(I) - APPROXIMATION TO THE INTEGRAL OVER C (ALIST(I),BLIST(I)) C RLIST2 - ARRAY OF DIMENSION AT LEAST (LIMEXP+2), C CONTAINING THE PART OF THE EPSILON TABLE C WICH IS STILL NEEDED FOR FURTHER COMPUTATIONS C ELIST(I) - ERROR ESTIMATE APPLYING TO RLIST(I) C MAXERR - POINTER TO THE INTERVAL WITH LARGEST ERROR C ESTIMATE C ERRMAX - ELIST(MAXERR) C ERLAST - ERROR ON THE INTERVAL CURRENTLY SUBDIVIDED C (BEFORE THAT SUBDIVISION HAS TAKEN PLACE) C AREA - SUM OF THE INTEGRALS OVER THE SUBINTERVALS C ERRSUM - SUM OF THE ERRORS OVER THE SUBINTERVALS C ERRBND - REQUESTED ACCURACY MAX(EPSABS,EPSREL* C ABS(RESULT)) C *****1 - VARIABLE FOR THE LEFT SUBINTERVAL C *****2 - VARIABLE FOR THE RIGHT SUBINTERVAL C LAST - INDEX FOR SUBDIVISION C NRES - NUMBER OF CALLS TO THE EXTRAPOLATION ROUTINE C NUMRL2 - NUMBER OF ELEMENTS CURRENTLY IN RLIST2. IF AN C APPROPRIATE APPROXIMATION TO THE COMPOUNDED C INTEGRAL HAS BEEN OBTAINED, IT IS PUT IN C RLIST2(NUMRL2) AFTER NUMRL2 HAS BEEN INCREASED C BY ONE. C SMALL - LENGTH OF THE SMALLEST INTERVAL CONSIDERED UP C TO NOW, MULTIPLIED BY 1.5 C ERLARG - SUM OF THE ERRORS OVER THE INTERVALS LARGER C THAN THE SMALLEST INTERVAL CONSIDERED UP TO NOW C EXTRAP - LOGICAL VARIABLE DENOTING THAT THE ROUTINE C IS ATTEMPTING TO PERFORM EXTRAPOLATION. I.E. C BEFORE SUBDIVIDING THE SMALLEST INTERVAL WE C TRY TO DECREASE THE VALUE OF ERLARG. C NOEXT - LOGICAL VARIABLE DENOTING THAT EXTRAPOLATION C IS NO LONGER ALLOWED (TRUE-VALUE) C C MACHINE DEPENDENT CONSTANTS C --------------------------- C C EPMACH IS THE LARGEST RELATIVE SPACING. C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. C OFLOW IS THE LARGEST POSITIVE MAGNITUDE. C EPMACH = SPMPAR(1) UFLOW = SPMPAR(2) OFLOW = SPMPAR(3) C C CHECK EPSABS AND EPSREL C ----------------------- C NEVAL = 0 LAST = 0 RESULT = 0.0 ABSERR = 0.0 ALIST(1) = 0.0 BLIST(1) = 1.0 RLIST(1) = 0.0 ELIST(1) = 0.0 IORD(1) = 0 IER = 6 IF (EPSABS .LT. 0.0 .OR. EPSREL .LT. 0.0) GO TO 999 IER = 0 RERR = AMAX1(EPSREL, 50.0*EPMACH, 0.5E-14) C C FIRST APPROXIMATION TO THE INTEGRAL C ----------------------------------- C C DETERMINE THE INTERVAL TO BE MAPPED ONTO (0,1). C IF INF = 2 THE INTEGRAL IS COMPUTED AS I = I1+I2, WHERE C I1 = INTEGRAL OF F OVER (-INFINITY,0), C I2 = INTEGRAL OF F OVER (0,+INFINITY). C BOUN = BOUND IF (INF .EQ. 2) BOUN = 0.0 CALL QK15I (F, BOUN, INF, 0.0, 1.0, RESULT, ABSERR, * DEFABS, RESABS, EPMACH, UFLOW) C C TEST ON ACCURACY C LAST = 1 RLIST(1) = RESULT ELIST(1) = ABSERR IORD(1) = 1 DRES = ABS(RESULT) ERRBND = AMAX1(EPSABS,RERR*DRES) IF (ABSERR .LE. 100.0*EPMACH*DEFABS .AND. ABSERR .GT. ERRBND) * IER = 2 IF (LIMIT .EQ. 1) IER = 1 IF (IER .NE. 0 .OR. (ABSERR .LE. ERRBND .AND. ABSERR .NE. RESABS) * .OR. ABSERR .EQ. 0.0) GO TO 130 C C INITIALIZATION C -------------- C RLIST2(1) = RESULT ERRMAX = ABSERR MAXERR = 1 AREA = RESULT ERRSUM = ABSERR ABSERR = OFLOW CORREC = 0.0 NRMAX = 1 NRES = 0 KTMIN = 0 NUMRL2 = 2 EXTRAP = .FALSE. NOEXT = .FALSE. IERRO = 0 IROFF1 = 0 IROFF2 = 0 IROFF3 = 0 KSGN = -1 IF (DRES .GE. (1.0 - 50.0*EPMACH)*DEFABS) KSGN = 1 T = 1.0 + 100.0*EPMACH C C MAIN DO-LOOP C ------------ C DO 90 LAST = 2,LIMIT C C BISECT THE SUBINTERVAL WITH NRMAX-TH LARGEST C ERROR ESTIMATE. C A1 = ALIST(MAXERR) B1 = 0.5*(ALIST(MAXERR) + BLIST(MAXERR)) A2 = B1 B2 = BLIST(MAXERR) ERLAST = ERRMAX CALL QK15I (F, BOUN, INF, A1, B1, AREA1, ERROR1, * RESABS, DEFAB1, EPMACH, UFLOW) CALL QK15I (F, BOUN, INF, A2, B2, AREA2, ERROR2, * RESABS, DEFAB2, EPMACH, UFLOW) C C IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL C AND ERROR AND TEST FOR ACCURACY. C AREA12 = AREA1 + AREA2 ERRO12 = ERROR1 + ERROR2 ERRSUM = ERRSUM + ERRO12 - ERRMAX AREA = AREA + AREA12 - RLIST(MAXERR) IF (DEFAB1 .EQ. ERROR1 .OR. DEFAB2 .EQ. ERROR2) GO TO 15 IF (ABS(RLIST(MAXERR) - AREA12) .GT. 0.1E-04*ABS(AREA12) * .OR. ERRO12 .LT. 0.99*ERRMAX) GO TO 10 IF (EXTRAP) IROFF2 = IROFF2 + 1 IF (.NOT.EXTRAP) IROFF1 = IROFF1 + 1 10 IF (LAST .GT. 10 .AND. ERRO12 .GT. ERRMAX) IROFF3 = IROFF3 + 1 15 RLIST(MAXERR) = AREA1 RLIST(LAST) = AREA2 ERRBND = AMAX1(EPSABS,RERR*ABS(AREA)) C C TEST FOR ROUNDOFF ERROR AND EVENTUALLY C SET ERROR FLAG. C IF (IROFF1 + IROFF2 .GE. 10 .OR. IROFF3 .GE. 20) IER = 2 IF (IROFF2 .GE. 5) IERRO = 3 C C SET ERROR FLAG IN THE CASE THAT THE NUMBER OF C SUBINTERVALS EQUALS LIMIT. C IF (LAST .EQ. LIMIT) IER = 1 C C SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR C AT SOME POINTS OF THE INTEGRATION RANGE. C IF (AMAX1(ABS(A1),ABS(B2)) .LE. * T*(ABS(A2) + 0.1E+04*UFLOW)) IER = 4 C C APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. C IF (ERROR2 .GT. ERROR1) GO TO 20 ALIST(LAST) = A2 BLIST(MAXERR) = B1 BLIST(LAST) = B2 ELIST(MAXERR) = ERROR1 ELIST(LAST) = ERROR2 GO TO 30 20 ALIST(MAXERR) = A2 ALIST(LAST) = A1 BLIST(LAST) = B1 RLIST(MAXERR) = AREA2 RLIST(LAST) = AREA1 ELIST(MAXERR) = ERROR2 ELIST(LAST) = ERROR1 C C CALL SUBROUTINE QPSRT TO MAINTAIN THE DESCENDING ORDERING C IN THE LIST OF ERROR ESTIMATES AND SELECT THE C SUBINTERVAL WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE C BISECTED NEXT). C 30 CALL QPSRT (LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX) IF (ERRSUM .LE. ERRBND) GO TO 115 IF (IER .NE. 0) GO TO 100 IF (LAST .EQ. 2) GO TO 80 IF (NOEXT) GO TO 90 ERLARG = ERLARG - ERLAST IF (ABS(B1 - A1) .GT. SMALL) ERLARG = ERLARG + ERRO12 IF (EXTRAP) GO TO 40 C C TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE C SMALLEST INTERVAL. C IF (ABS(BLIST(MAXERR) - ALIST(MAXERR)) .GT. SMALL) GO TO 90 EXTRAP = .TRUE. NRMAX = 2 40 IF (IERRO .EQ. 3 .OR. ERLARG .LE. ERTEST) GO TO 60 C C THE SMALLEST INTERVAL HAS THE LARGEST ERROR. C BEFORE BISECTING DECREASE THE SUM OF THE ERRORS C OVER THE LARGER INTERVALS (ERLARG) AND PERFORM C EXTRAPOLATION. C ID = NRMAX JUPBND = LAST IF (LAST .GT. (2 + LIMIT/2)) JUPBND = LIMIT + 3 - LAST DO 50 K = ID,JUPBND MAXERR = IORD(NRMAX) ERRMAX = ELIST(MAXERR) IF (ABS(BLIST(MAXERR) - ALIST(MAXERR)) .GT. SMALL) GO TO 90 NRMAX = NRMAX + 1 50 CONTINUE C C PERFORM EXTRAPOLATION. C 60 NUMRL2 = NUMRL2 + 1 RLIST2(NUMRL2) = AREA CALL QELG (NUMRL2, RLIST2, RESEPS, ABSEPS, RES3LA, NRES, * EPMACH, OFLOW) KTMIN = KTMIN + 1 IF (KTMIN .GT. 5 .AND. ABSERR .LT. 0.1E-02*ERRSUM) IER = 5 IF (ABSEPS .GE. ABSERR) GO TO 70 KTMIN = 0 ABSERR = ABSEPS RESULT = RESEPS CORREC = ERLARG ERTEST = AMAX1(EPSABS,RERR*ABS(RESEPS)) IF (ABSERR .LE. ERTEST) GO TO 100 C C PREPARE BISECTION OF THE SMALLEST INTERVAL. C 70 IF (NUMRL2 .EQ. 1) NOEXT = .TRUE. IF (IER .EQ. 5) GO TO 100 MAXERR = IORD(1) ERRMAX = ELIST(MAXERR) NRMAX = 1 EXTRAP = .FALSE. SMALL = SMALL*0.5 ERLARG = ERRSUM GO TO 90 80 SMALL = 0.375 ERLARG = ERRSUM ERTEST = ERRBND RLIST2(2) = AREA 90 CONTINUE C C SET FINAL RESULT AND ERROR ESTIMATE. C ------------------------------------ C 100 IF (ABSERR .EQ. OFLOW) GO TO 115 IF (IER + IERRO .EQ. 0) GO TO 110 IF (IERRO .EQ. 3) ABSERR = ABSERR + CORREC IF (IER .EQ. 0) IER = 3 IF (RESULT .NE. 0.0 .AND. AREA .NE. 0.0) GO TO 105 IF (ABSERR .GT. ERRSUM) GO TO 115 IF (AREA .EQ. 0.0) GO TO 130 GO TO 110 105 IF (ABSERR/ABS(RESULT) .GT. ERRSUM/ABS(AREA)) GO TO 115 C C TEST ON DIVERGENCE C 110 IF (KSGN .EQ. -1 .AND. AMAX1(ABS(RESULT),ABS(AREA)) .LE. * DEFABS*0.1E-01) GO TO 130 IF (0.1E-01 .GT. (RESULT/AREA) .OR. (RESULT/AREA) .GT. 0.1E+03 * .OR. ERRSUM .GT. ABS(AREA)) IER = 6 GO TO 130 C C COMPUTE GLOBAL INTEGRAL SUM. C 115 RESULT = 0.0 DO 120 K = 1,LAST RESULT = RESULT + RLIST(K) 120 CONTINUE ABSERR = ERRSUM 130 NEVAL = 30*LAST - 15 IF (INF .EQ. 2) NEVAL = 2*NEVAL IF (IER .GT. 2) IER = IER - 1 999 RETURN END SUBROUTINE QK15I (F, BOUN, INF, A, B, RESULT, ABSERR, RESABS, * RESASC, EPMACH, UFLOW) C----------------------------------------------------------------------- C C 1. PURPOSE C THE ORIGINAL (INFINITE) INTEGRATION RANGE IS MAPPED C ONTO THE INTERVAL (0,1) AND (A,B) IS A PART OF (0,1). C IT IS THE PURPOSE TO COMPUTE C I = INTEGRAL OF TRANSFORMED INTEGRAND OVER (A,B), C J = INTEGRAL OF ABS(TRANSFORMED INTEGRAND) OVER (A,B). C C 2. PARAMETERS C ON ENTRY C F - REAL C FUNCTION SUBPROGRAM DEFINING THE INTEGRAND C FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS C TO BE DECLARED E X T E R N A L IN THE C CALLING PROGRAM. C C BOUN - REAL C FINITE BOUND OF ORIGINAL INTEGRATION C RANGE (SET TO ZERO IF INF = +2) C C INF - INTEGER C IF INF = -1, THE ORIGINAL INTERVAL IS C (-INFINITY,BOUND), C IF INF = +1, THE ORIGINAL INTERVAL IS C (BOUND,+INFINITY), C IF INF = +2, THE ORIGINAL INTERVAL IS C (-INFINITY,+INFINITY) AND C THE INTEGRAL IS COMPUTED AS THE SUM OF TWO C INTEGRALS, ONE OVER (-INFINITY,0) C AND ONE OVER (0,+INFINITY). C C A - REAL C LOWER LIMIT FOR INTEGRATION OVER SUBRANGE C OF (0,1) C C B - REAL C UPPER LIMIT FOR INTEGRATION OVER SUBRANGE C OF (0,1) C C EPMACH - REAL C THE RELATIVE PRECISION OF THE FLOATING C ARITHMETIC BEING USED. C C UFLOW - REAL C THE SMALLEST POSITIVE MAGNITUDE. C C ON RETURN C RESULT - REAL C APPROXIMATION TO THE INTEGRAL I C RESULT IS COMPUTED BY APPLYING THE 15-POINT C KRONROD RULE(RESK) OBTAINED BY OPTIMAL C ADDITION OF ABSCISSAE TO THE 7-POINT GAUSS C RULE(RESG). C C ABSERR - REAL C ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR, C WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT) C C RESABS - REAL C APPROXIMATION TO THE INTEGRAL J C C RESASC - REAL C APPROXIMATION TO THE INTEGRAL OF C ABS((TRANSFORMED INTEGRAND)-I/(B-A)) C OVER (A,B) C C 3. SUBROUTINES OR FUNCTIONS NEEDED C - F (USER-PROVIDED FUNCTION) C C----------------------------------------------------------------------- REAL FV1(7), FV2(7), XGK(8), WGK(8), WG(8) EXTERNAL F C C THE ABSCISSAE AND WEIGHTS ARE SUPPLIED FOR THE INTERVAL C (-1,1). BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND C THEIR CORRESPONDING WEIGHTS ARE GIVEN. C C XGK - ABSCISSAE OF THE 15-POINT KRONROD RULE C XGK(2), XGK(4), ... ABSCISSAE OF THE 7-POINT C GAUSS RULE C XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY C ADDED TO THE 7-POINT GAUSS RULE C C WGK - WEIGHTS OF THE 15-POINT KRONROD RULE C C WG - WEIGHTS OF THE 7-POINT GAUSS RULE, CORRESPONDING C TO THE ABSCISSAE XGK(2), XGK(4), ... C WG(1), WG(3), ... ARE SET TO ZERO. C DATA XGK(1),XGK(2),XGK(3),XGK(4),XGK(5),XGK(6),XGK(7), * XGK(8)/ * 0.9914553711208126E+00, 0.9491079123427585E+00, * 0.8648644233597691E+00, 0.7415311855993944E+00, * 0.5860872354676911E+00, 0.4058451513773972E+00, * 0.2077849550078985E+00, 0.0000000000000000E+00/ C DATA WGK(1),WGK(2),WGK(3),WGK(4),WGK(5),WGK(6),WGK(7), * WGK(8)/ * 0.2293532201052922E-01, 0.6309209262997855E-01, * 0.1047900103222502E+00, 0.1406532597155259E+00, * 0.1690047266392679E+00, 0.1903505780647854E+00, * 0.2044329400752989E+00, 0.2094821410847278E+00/ C DATA WG(1),WG(2),WG(3),WG(4),WG(5),WG(6),WG(7),WG(8)/ * 0.0000000000000000E+00, 0.1294849661688697E+00, * 0.0000000000000000E+00, 0.2797053914892767E+00, * 0.0000000000000000E+00, 0.3818300505051189E+00, * 0.0000000000000000E+00, 0.4179591836734694E+00/ C C C LIST OF MAJOR VARIABLES C ----------------------- C C CENTR - MID POINT OF THE INTERVAL C HLGTH - HALF-LENGTH OF THE INTERVAL C ABSC* - ABSCISSA C TABSC* - TRANSFORMED ABSCISSA C FVAL* - FUNCTION VALUE C RESG - RESULT OF THE 7-POINT GAUSS FORMULA C RESK - RESULT OF THE 15-POINT KRONROD FORMULA C RESKH - APPROXIMATION TO THE MEAN VALUE OF THE TRANSFORMED C INTEGRAND OVER (A,B), I.E. TO I/(B-A) C C DINF = MIN0(1,INF) C CENTR = 0.5*(A + B) HLGTH = 0.5*(B - A) TABSC1 = BOUN + DINF*(1.0 - CENTR)/CENTR FVAL1 = F(TABSC1) IF (INF .EQ. 2) FVAL1 = FVAL1 + F(-TABSC1) FC = (FVAL1/CENTR)/CENTR C C COMPUTE THE 15-POINT KRONROD APPROXIMATION TO C THE INTEGRAL, AND ESTIMATE THE ERROR. C RESG = WG(8)*FC RESK = WGK(8)*FC RESABS = ABS(RESK) DO 10 J = 1,7 ABSC = HLGTH*XGK(J) ABSC1 = CENTR - ABSC ABSC2 = CENTR + ABSC TABSC1 = BOUN + DINF*(1.0 - ABSC1)/ABSC1 TABSC2 = BOUN + DINF*(1.0 - ABSC2)/ABSC2 FVAL1 = F(TABSC1) FVAL2 = F(TABSC2) IF (INF .EQ. 2) FVAL1 = FVAL1 + F(-TABSC1) IF (INF .EQ. 2) FVAL2 = FVAL2 + F(-TABSC2) FVAL1 = (FVAL1/ABSC1)/ABSC1 FVAL2 = (FVAL2/ABSC2)/ABSC2 FV1(J) = FVAL1 FV2(J) = FVAL2 FSUM = FVAL1 + FVAL2 RESG = RESG + WG(J)*FSUM RESK = RESK + WGK(J)*FSUM RESABS = RESABS + WGK(J)*(ABS(FVAL1) + ABS(FVAL2)) 10 CONTINUE RESKH = RESK*0.5 RESASC = WGK(8)*ABS(FC - RESKH) DO 20 J = 1,7 RESASC = RESASC + WGK(J)*(ABS(FV1(J)-RESKH) + * ABS(FV2(J)-RESKH)) 20 CONTINUE RESULT = RESK*HLGTH RESASC = RESASC*HLGTH RESABS = RESABS*HLGTH ABSERR = ABS((RESK - RESG)*HLGTH) IF (RESASC .NE. 0.0 .AND. ABSERR .NE. 0.0) ABSERR = RESASC* * AMIN1(1.0, (0.2E+03*ABSERR/RESASC)**1.5) TOL = 50.0*EPMACH IF (RESABS .GT. UFLOW/TOL) ABSERR = AMAX1(ABSERR, TOL*RESABS) RETURN END SUBROUTINE QPSRT(LIMIT,LAST,MAXERR,ERMAX,ELIST,IORD,NRMAX) C .................................................................. C C 1. QPSRT C ORDERING ROUTINE C STANDARD FORTRAN SUBROUTINE C REAL VERSION C C 2. PURPOSE C THIS ROUTINE MAINTAINS THE DESCENDING ORDERING C IN THE LIST OF THE LOCAL ERROR ESTIMATES RESULTING FROM C THE INTERVAL SUBDIVISION PROCESS. AT EACH CALL TWO ERROR C ESTIMATES ARE INSERTED USING THE SEQUENTIAL SEARCH C METHOD, TOP-DOWN FOR THE LARGEST ERROR ESTIMATE C AND BOTTOM-UP FOR THE SMALLEST ERROR ESTIMATE. C C 3. CALLING SEQUENCE C CALL QPSRT(LIMIT,LAST,MAXERR,ERMAX,ELIST,IORD,NRMAX) C C PARAMETERS (MEANING AT OUTPUT) C LIMIT - INTEGER C MAXIMUM NUMBER OF ERROR ESTIMATES THE LIST C CAN CONTAIN C C LAST - INTEGER C NUMBER OF ERROR ESTIMATES CURRENTLY C IN THE LIST C C MAXERR - INTEGER C MAXERR POINTS TO THE NRMAX-TH LARGEST ERROR C ESTIMATE CURRENTLY IN THE LIST C C ERMAX - REAL C NRMAX-TH LARGEST ERROR ESTIMATE C ERMAX = ELIST(MAXERR) C C ELIST - REAL C VECTOR OF DIMENSION LAST CONTAINING C THE ERROR ESTIMATES C C IORD - INTEGER C VECTOR OF DIMENSION LAST, THE FIRST K C ELEMENTS OF WHICH CONTAIN POINTERS C TO THE ERROR ESTIMATES, SUCH THAT C ELIST(IORD(1)),... , ELIST(IORD(K)) C FORM A DECREASING SEQUENCE, WITH C K = LAST IF LAST.LE.(LIMIT/2+2), AND C K = LIMIT+1-LAST OTHERWISE C C NRMAX - INTEGER C MAXERR = IORD(NRMAX) C C 4. NO SUBROUTINES OR FUNCTIONS NEEDED C C .................................................................. C REAL ELIST,ERMAX,ERRMAX,ERRMIN INTEGER I,IBEG,IDO,IORD,ISUCC,J,JBND,JUPBN,K,LAST,LIMIT,MAXERR, * NRMAX DIMENSION ELIST(LAST),IORD(LAST) C C CHECK WHETHER THE LIST CONTAINS MORE THAN C TWO ERROR ESTIMATES. C C***FIRST EXECUTABLE STATEMENT QPSRT IF(LAST.GT.2) GO TO 10 IORD(1) = 1 IORD(2) = 2 GO TO 90 C C THIS PART OF THE ROUTINE IS ONLY EXECUTED C IF, DUE TO A DIFFICULT INTEGRAND, SUBDIVISION C INCREASED THE ERROR ESTIMATE. IN THE NORMAL CASE C THE INSERT PROCEDURE SHOULD START AFTER THE C NRMAX-TH LARGEST ERROR ESTIMATE. C 10 ERRMAX = ELIST(MAXERR) IF(NRMAX.EQ.1) GO TO 30 IDO = NRMAX-1 DO 20 I = 1,IDO ISUCC = IORD(NRMAX-1) C ***JUMP OUT OF DO-LOOP IF(ERRMAX.LE.ELIST(ISUCC)) GO TO 30 IORD(NRMAX) = ISUCC NRMAX = NRMAX-1 20 CONTINUE C C COMPUTE THE NUMBER OF ELEMENTS IN THE LIST TO C BE MAINTAINED IN DESCENDING ORDER. THIS NUMBER C DEPENDS ON THE NUMBER OF SUBDIVISIONS STILL C ALLOWED. C 30 JUPBN = LAST IF(LAST.GT.(LIMIT/2+2)) JUPBN = LIMIT+3-LAST ERRMIN = ELIST(LAST) C C INSERT ERRMAX BY TRAVERSING THE LIST TOP-DOWN, C STARTING COMPARISON FROM THE ELEMENT ELIST(IORD(NRMAX+1)). C JBND = JUPBN-1 IBEG = NRMAX+1 IF(IBEG.GT.JBND) GO TO 50 DO 40 I=IBEG,JBND ISUCC = IORD(I) C ***JUMP OUT OF DO-LOOP IF(ERRMAX.GE.ELIST(ISUCC)) GO TO 60 IORD(I-1) = ISUCC 40 CONTINUE 50 IORD(JBND) = MAXERR IORD(JUPBN) = LAST GO TO 90 C C INSERT ERRMIN BY TRAVERSING THE LIST BOTTOM-UP. C 60 IORD(I-1) = MAXERR K = JBND DO 70 J=I,JBND ISUCC = IORD(K) C ***JUMP OUT OF DO-LOOP IF(ERRMIN.LT.ELIST(ISUCC)) GO TO 80 IORD(K+1) = ISUCC K = K-1 70 CONTINUE IORD(I) = LAST GO TO 90 80 IORD(K+1) = LAST C C SET MAXERR AND ERMAX. C 90 MAXERR = IORD(NRMAX) ERMAX = ELIST(MAXERR) RETURN END SUBROUTINE QELG (N, EPSTAB, RESULT, ABSERR, RES3LA, NRES, * EPMACH, OFLOW) C----------------------------------------------------------------------- C C 1. PURPOSE C THE ROUTINE DETERMINES THE LIMIT OF A GIVEN SEQUENCE OF C APPROXIMATIONS, BY MEANS OF THE EPSILON ALGORITHM C OF P. WYNN. C AN ESTIMATE OF THE ABSOLUTE ERROR IS ALSO GIVEN. C THE CONDENSED EPSILON TABLE IS COMPUTED. ONLY THOSE C ELEMENTS NEEDED FOR THE COMPUTATION OF THE NEXT DIAGONAL C ARE PRESERVED. C C 2. PARAMETERS C N - INTEGER C EPSTAB(N) CONTAINS THE NEW ELEMENT IN THE C FIRST COLUMN OF THE EPSILON TABLE. C C EPSTAB - REAL C VECTOR OF DIMENSION 52 CONTAINING THE C ELEMENTS OF THE TWO LOWER DIAGONALS OF C THE TRIANGULAR EPSILON TABLE C THE ELEMENTS ARE NUMBERED STARTING AT THE C RIGHT-HAND CORNER OF THE TRIANGLE. C C RESULT - REAL C RESULTING APPROXIMATION TO THE INTEGRAL C C ABSERR - REAL C ESTIMATE OF THE ABSOLUTE ERROR COMPUTED FROM C RESULT AND THE 3 PREVIOUS RESULTS C C RES3LA - REAL C VECTOR OF DIMENSION 3 CONTAINING THE LAST 3 C RESULTS C C NRES - INTEGER C NUMBER OF CALLS TO THE ROUTINE C (SHOULD BE ZERO AT FIRST CALL) C C EPMACH - REAL C THE RELATIVE PRECISION OF THE FLOATING C ARITHMETIC BEING USED. C C OFLOW - REAL C THE LARGEST POSITIVE MAGNITUDE. C C 3. NO SUBROUTINES OR FUNCTIONS USED C C----------------------------------------------------------------------- REAL EPSTAB(52), RES3LA(3) C--------------------- C C LIST OF MAJOR VARIABLES C ----------------------- C C E0 - THE 4 ELEMENTS ON WHICH THE C E1 COMPUTATION OF A NEW ELEMENT IN C E2 THE EPSILON TABLE IS BASED C E3 E0 C E3 E1 NEW C E2 C NEWELM - NUMBER OF ELEMENTS TO BE COMPUTED IN THE NEW C DIAGONAL C ERROR - ERROR = ABS(E1-E0)+ABS(E2-E1)+ABS(NEW-E2) C RESULT - THE ELEMENT IN THE NEW DIAGONAL WITH LEAST VALUE C OF ERROR C C LIMEXP IS THE MAXIMUM NUMBER OF ELEMENTS THE EPSILON C TABLE CAN CONTAIN. IF THIS NUMBER IS REACHED, THE UPPER C DIAGONAL OF THE EPSILON TABLE IS DELETED. C NRES = NRES + 1 ABSERR = OFLOW RESULT = EPSTAB(N) IF (N .LT. 3) GO TO 100 LIMEXP = 50 EPSTAB(N + 2) = EPSTAB(N) NEWELM = (N - 1)/2 EPSTAB(N) = OFLOW NUM = N K1 = N DO 40 I = 1,NEWELM K2 = K1 - 1 K3 = K1 - 2 RES = EPSTAB(K1 + 2) E0 = EPSTAB(K3) E1 = EPSTAB(K2) E2 = RES E1ABS = ABS(E1) DELTA2 = E2 - E1 ERR2 = ABS(DELTA2) TOL2 = AMAX1(ABS(E2),E1ABS)*EPMACH DELTA3 = E1 - E0 ERR3 = ABS(DELTA3) TOL3 = AMAX1(E1ABS,ABS(E0))*EPMACH IF (ERR2 .GT. TOL2 .OR. ERR3 .GT. TOL3) GO TO 10 C C IF E0, E1 AND E2 ARE EQUAL TO WITHIN MACHINE C ACCURACY, CONVERGENCE IS ASSUMED. C RESULT = E2 C ABSERR = ABS(E1-E0) + ABS(E2-E1) C RESULT = RES ABSERR = ERR2 + ERR3 C ***JUMP OUT OF DO-LOOP GO TO 100 10 E3 = EPSTAB(K1) EPSTAB(K1) = E1 DELTA1 = E1 - E3 ERR1 = ABS(DELTA1) TOL1 = AMAX1(E1ABS,ABS(E3))*EPMACH C C IF TWO ELEMENTS ARE VERY CLOSE TO EACH OTHER, OMIT C A PART OF THE TABLE BY ADJUSTING THE VALUE OF N C IF (ERR1.LE.TOL1 .OR. ERR2.LE.TOL2 .OR. ERR3.LE.TOL3) GO TO 20 SS = 1.0/DELTA1 + 1.0/DELTA2 - 1.0/DELTA3 EPSINF = ABS(SS*E1) C C TEST TO DETECT IRREGULAR BEHAVIOUR IN THE TABLE, AND C EVENTUALLY OMIT A PART OF THE TABLE ADJUSTING THE VALUE C OF N. C IF (EPSINF .GT. 0.1E-03) GO TO 30 20 N = I + I - 1 C ***JUMP OUT OF DO-LOOP GO TO 50 C C COMPUTE A NEW ELEMENT AND EVENTUALLY ADJUST C THE VALUE OF RESULT. C 30 RES = E1 + 1.0/SS EPSTAB(K1) = RES K1 = K1 - 2 ERROR = ERR2 + ABS(RES - E2) + ERR3 IF (ERROR .GT. ABSERR) GO TO 40 ABSERR = ERROR RESULT = RES 40 CONTINUE C C SHIFT THE TABLE. C 50 IF (N .EQ. LIMEXP) N = 2*(LIMEXP/2) - 1 IB = 1 IF ((NUM/2)*2 .EQ. NUM) IB = 2 IE = NEWELM + 1 DO 60 I = 1,IE IB2 = IB + 2 EPSTAB(IB) = EPSTAB(IB2) IB = IB2 60 CONTINUE IF (NUM .EQ. N) GO TO 80 INDX = NUM - N + 1 DO 70 I = 1,N EPSTAB(I) = EPSTAB(INDX) INDX = INDX + 1 70 CONTINUE 80 IF (NRES .GE. 4) GO TO 90 RES3LA(NRES) = RESULT ABSERR = OFLOW GO TO 100 C C COMPUTE ERROR ESTIMATE C 90 ABSERR = ABS(RESULT - RES3LA(3)) + ABS(RESULT - RES3LA(2)) + * ABS(RESULT - RES3LA(1)) RES3LA(1) = RES3LA(2) RES3LA(2) = RES3LA(3) RES3LA(3) = RESULT 100 ABSERR = AMAX1(ABSERR,5.0*EPMACH*ABS(RESULT)) RETURN END SUBROUTINE QXGS (F,A,B,EPSABS,EPSREL,RESULT,ABSERR,IER, * LIMIT,LENIW,LENW,LAST,IWORK,WORK) C C THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO A GIVEN C DEFINITE INTEGRAL I = INTEGRAL OF F OVER (A,B), C HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY C ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). C C PARAMETERS C ON ENTRY C F - REAL C FUNCTION SUBPROGRAM DEFINING THE INTEGRAND C FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE C DECLARED E X T E R N A L IN THE DRIVER PROGRAM. C C A - REAL C LOWER LIMIT OF INTEGRATION C C B - REAL C UPPER LIMIT OF INTEGRATION C C EPSABS - REAL C ABSOLUTE ACCURACY REQUESTED C C EPSREL - REAL C RELATIVE ACCURACY REQUESTED C C ON RETURN C RESULT - REAL C APPROXIMATION TO THE INTEGRAL C C ABSERR - REAL C ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR, C WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT) C C IER - INTEGER C IER = 0 NORMAL AND RELIABLE TERMINATION OF THE C ROUTINE. IT IS ASSUMED THAT THE REQUESTED C ACCURACY HAS BEEN ACHIEVED. C IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE C THE ESTIMATES FOR INTEGRAL AND ERROR ARE C LESS RELIABLE. IT IS ASSUMED THAT THE C REQUESTED ACCURACY HAS NOT BEEN ACHIEVED. C ERROR MESSAGES C IER = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED C HAS BEEN ACHIEVED. ONE CAN ALLOW MORE SUB- C DIVISIONS BY INCREASING THE VALUE OF LIMIT C (AND TAKING THE ACCORDING DIMENSION C ADJUSTMENTS INTO ACCOUNT. HOWEVER, IF C THIS YIELDS NO IMPROVEMENT IT IS ADVISED C TO ANALYZE THE INTEGRAND IN ORDER TO C DETERMINE THE INTEGRATION DIFFICULTIES. IF C THE POSITION OF A LOCAL DIFFICULTY CAN BE C DETERMINED (E.G. SINGULARITY, C DISCONTINUITY WITHIN THE INTERVAL) ONE C WILL PROBABLY GAIN FROM SPLITTING UP THE C INTERVAL AT THIS POINT AND CALLING THE C INTEGRATOR ON THE SUBRANGES. IF POSSIBLE, C AN APPROPRIATE SPECIAL-PURPOSE INTEGRATOR C SHOULD BE USED, WHICH IS DESIGNED FOR C HANDLING THE TYPE OF DIFFICULTY INVOLVED. C = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS DETEC- C TED, WHICH PREVENTS THE REQUESTED C TOLERANCE FROM BEING ACHIEVED. C THE ERROR MAY BE UNDER-ESTIMATED. C = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR C OCCURS AT SOME POINTS OF THE INTEGRATION C INTERVAL. C = 4 THE ALGORITHM DOES NOT CONVERGE. C ROUNDOFF ERROR IS DETECTED IN THE C EXTRAPOLATION TABLE. IT IS PRESUMED THAT C THE REQUESTED TOLERANCE CANNOT BE C ACHIEVED, AND THAT THE RETURNED RESULT IS C THE BEST WHICH CAN BE OBTAINED. C = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR C SLOWLY CONVERGENT. IT MUST BE NOTED THAT C DIVERGENCE CAN OCCUR WITH ANY OTHER VALUE C OF IER. C = 6 THE INPUT IS INVALID BECAUSE EPSABS OR C EPSREL IS NEGATIVE, LIMIT .LT. 1, C LENW .LT. 46*LIMIT, OR C LENIW .LT. 3*LIMIT. C RESULT, ABSERR, LAST ARE SET TO C ZERO. EXCEPT WHEN LIMIT OR LENW OR LENIW C IS INVALID, IWORK(1), WORK(LIMIT*2+1) AND C WORK(LIMIT*3+1) ARE SET TO ZERO, WORK(1) C IS SET TO A, AND WORK(LIMIT+1) TO B. C C DIMENSIONING PARAMETERS C LIMIT - INTEGER C LIMIT DETERMINES THE MAXIMUM NUMBER OF SUBINTERVALS C IN THE PARTITION OF THE GIVEN INTEGRATION INTERVAL C (A,B), LIMIT.GE.1. C IF LIMIT.LT.1, THE ROUTINE WILL END WITH IER = 6. C C LENW - INTEGER C DIMENSIONING PARAMETER FOR WORK C LENW MUST BE AT LEAST LIMIT*46. C IF LENW.LT.LIMIT*46, THE ROUTINE WILL END C WITH IER = 6. C C LENIW - INTEGER C DIMENSIONING PARAMETER FOR IWORK C LENIW MUST BE AT LEAST LIMIT*3. C IF LENW.LT.LIMIT*3, THE ROUTINE WILL END C WITH IER = 6. C C LAST - INTEGER C ON RETURN, LAST EQUALS THE NUMBER OF SUBINTERVALS C PRODUCED IN THE SUBDIVISION PROCESS, WHICH DETER- C MINES THE NUMBER OF SIGNIFICANT ELEMENTS ACTUALLY C IN THE WORK ARRAYS. C C WORK ARRAYS C IWORK - INTEGER C VECTOR OF DIMENSION AT LEAST 3*LIMIT, THE FIRST K C ELEMENTS OF WHICH CONTAIN POINTERS C TO THE ERROR ESTIMATES OVER THE SUBINTERVALS C SUCH THAT WORK(LIMIT*3+IWORK(1)),... , C WORK(LIMIT*3+IWORK(K)) FORM A DECREASING C SEQUENCE, WITH K = LAST IF LAST.LE.(LIMIT/2+2), C AND K = LIMIT+1-LAST OTHERWISE. C C WORK - REAL C VECTOR OF DIMENSION AT LEAST LENW C ON RETURN C WORK(1), ..., WORK(LAST) CONTAIN THE LEFT C END-POINTS OF THE SUBINTERVALS IN THE C PARTITION OF (A,B), C WORK(LIMIT+1), ..., WORK(LIMIT+LAST) CONTAIN C THE RIGHT END-POINTS, C WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) CONTAIN C THE INTEGRAL APPROXIMATIONS OVER THE SUBINTERVALS, C WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST) C CONTAIN THE ERROR ESTIMATES. C WORK(LIMIT*4+1), ... IS THE AREA RESERVED TO STORE C FUNCTIONAL VALUES. C REAL A,ABSERR,B,EPSABS,EPSREL,F,RESULT,WORK INTEGER IER,IWORK,LAST,LENIW,LENW,LIMIT,L1,L2,L3,L4,L5 C DIMENSION IWORK(LENIW),WORK(LENW) C EXTERNAL F C C CHECK VALIDITY OF LIMIT,LENIW AND LENW. C IER = 6 LAST = 0 RESULT = 0.0 ABSERR = 0.0 IF (LIMIT.LT.1 .OR. LENIW.LT.LIMIT*3 .OR. LENW.LT.LIMIT*46) * RETURN C C PREPARE CALL FOR QXGSE. C L1 = LIMIT + 1 L2 = LIMIT + L1 L3 = LIMIT + L2 L4 = LIMIT + L3 L5 = 21*LIMIT + L4 C CALL QXGSE(F,A,B,EPSABS,EPSREL,LIMIT,RESULT,ABSERR, * IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST, * WORK(L4),WORK(L5),IWORK(L1),IWORK(L2)) C RETURN END SUBROUTINE QXGSE(F,A,B,EPSABS,EPSREL,LIMIT,RESULT,ABSERR, * IER,ALIST,BLIST,RLIST,ELIST,IORD,LAST,VALP,VALN,LP,LN) C C THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO A C DEFINITE INTEGRAL I = INTEGRAL OF F OVER (A,B), C HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY C ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). C C PARAMETERS C ON ENTRY C F - REAL C FUNCTION SUBPROGRAM DEFINING THE INTEGRAND C FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE C DECLARED E X T E R N A L IN THE DRIVER PROGRAM. C C A - REAL C LOWER LIMIT OF INTEGRATION C C B - REAL C UPPER LIMIT OF INTEGRATION C C EPSABS - REAL C ABSOLUTE ACCURACY REQUESTED C C EPSREL - REAL C RELATIVE ACCURACY REQUESTED C C LIMIT - INTEGER C GIVES AN UPPERBOUND ON THE NUMBER OF SUBINTERVALS C IN THE PARTITION OF (A,B) C C ON RETURN C RESULT - REAL C APPROXIMATION TO THE INTEGRAL C C ABSERR - REAL C ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR, C WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT) C C IER - INTEGER C IER = 0 NORMAL AND RELIABLE TERMINATION OF THE C ROUTINE. IT IS ASSUMED THAT THE REQUESTED C ACCURACY HAS BEEN ACHIEVED. C IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE C THE ESTIMATES FOR INTEGRAL AND ERROR ARE C LESS RELIABLE. IT IS ASSUMED THAT THE C REQUESTED ACCURACY HAS NOT BEEN ACHIEVED. C ERROR MESSAGES C = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED C HAS BEEN ACHIEVED. ONE CAN ALLOW MORE SUB- C DIVISIONS BY INCREASING THE VALUE OF LIMIT C (AND TAKING THE ACCORDING DIMENSION C ADJUSTMENTS INTO ACCOUNT). HOWEVER, IF C THIS YIELDS NO IMPROVEMENT IT IS ADVISED C TO ANALYZE THE INTEGRAND IN ORDER TO C DETERMINE THE INTEGRATION DIFFICULTIES. IF C THE POSITION OF A LOCAL DIFFICULTY CAN BE C DETERMINED (E.G. SINGULARITY, C DISCONTINUITY WITHIN THE INTERVAL) ONE C WILL PROBABLY GAIN FROM SPLITTING UP THE C INTERVAL AT THIS POINT AND CALLING THE C INTEGRATOR ON THE SUBRANGES. IF POSSIBLE, C AN APPROPRIATE SPECIAL-PURPOSE INTEGRATOR C SHOULD BE USED, WHICH IS DESIGNED FOR C HANDLING THE TYPE OF DIFFICULTY INVOLVED. C = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS DETEC- C TED, WHICH PREVENTS THE REQUESTED C TOLERANCE FROM BEING ACHIEVED. C THE ERROR MAY BE UNDER-ESTIMATED. C = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR C OCCURS AT SOME POINTS OF THE INTEGRATION C INTERVAL. C = 4 THE ALGORITHM DOES NOT CONVERGE. C ROUNDOFF ERROR IS DETECTED IN THE C EXTRAPOLATION TABLE. C IT IS PRESUMED THAT THE REQUESTED C TOLERANCE CANNOT BE ACHIEVED, AND THAT THE C RETURNED RESULT IS THE BEST WHICH CAN BE C OBTAINED. C = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR C SLOWLY CONVERGENT. IT MUST BE NOTED THAT C DIVERGENCE CAN OCCUR WITH ANY OTHER VALUE C OF IER. C = 6 THE INPUT IS INVALID BECAUSE EPSABS OR C EPSREL IS NEGATIVE. RESULT, ABSERR, C LAST, RLIST(1), IORD(1), AND ELIST(1) C ARE SET TO ZERO. ALIST(1) AND BLIST(1) C ARE SET TO A AND B RESPECTIVELY. C C ALIST - REAL C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST C LAST ELEMENTS OF WHICH ARE THE LEFT END POINTS C OF THE SUBINTERVALS IN THE PARTITION OF THE C GIVEN INTEGRATION RANGE (A,B) C C BLIST - REAL C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST C LAST ELEMENTS OF WHICH ARE THE RIGHT END POINTS C OF THE SUBINTERVALS IN THE PARTITION OF THE GIVEN C INTEGRATION RANGE (A,B) C C RLIST - REAL C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST C LAST ELEMENTS OF WHICH ARE THE INTEGRAL C APPROXIMATIONS ON THE SUBINTERVALS C C ELIST - REAL C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST C LAST ELEMENTS OF WHICH ARE THE MODULI OF THE C ABSOLUTE ERROR ESTIMATES ON THE SUBINTERVALS C C IORD - INTEGER C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST K C ELEMENTS OF WHICH ARE POINTERS TO THE C ERROR ESTIMATES OVER THE SUBINTERVALS, C SUCH THAT ELIST(IORD(1)), ..., ELIST(IORD(K)) C FORM A DECREASING SEQUENCE, WITH K = LAST C IF LAST.LE.(LIMIT/2+2), AND K = LIMIT+1-LAST C OTHERWISE C C LAST - INTEGER C NUMBER OF SUBINTERVALS ACTUALLY PRODUCED IN THE C SUBDIVISION PROCESS C C VALP - REAL C VALN ARRAYS OF DIMENSION AT LEAST (21,LIMIT) USED TO C SAVE THE FUNCTIONAL VALUES C C LP - INTEGER C LN VECTORS OF DIMENSION AT LEAST LIMIT, USED TO C STORE THE ACTUAL NUMBER OF FUNCTIONAL VALUES C SAVED IN THE CORRESPONDING COLUMN C OF VALP,VALN C C***ROUTINES CALLED F,SPMPAR,QELG,QXLQM,QPSRT,QXRRD,QXCPY C REAL A,ABSEPS,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1,A2, * B,BLIST,B1,B2,CORREC,DEFABS,DEFAB1,DEFAB2,DRES,ELIST, * EPMACH,EPSABS,EPSREL,ERLARG,ERLAST,ERRBND,ERRMAX, * ERROR1,ERROR2,ERRO12,ERRSUM,ERTEST,F,OFLOW,RERR,RESABS, * RESEPS,RESULT,RES3LA,RLIST,RLIST2,SMALL,T,UFLOW, * VALP,VALN,VP1,VP2,VN1,VN2,SPMPAR INTEGER ID,IER,IERRO,IORD,IROFF1,IROFF2,IROFF3,JUPBND,K,KSGN, * KTMIN,LAST,LIMIT,MAXERR,NRES,NRMAX,NUMRL2, * LP,LN,LP1,LP2,LN1,LN2 LOGICAL EXTRAP,NOEXT C DIMENSION ALIST(LIMIT),BLIST(LIMIT),ELIST(LIMIT),IORD(LIMIT), * RES3LA(3),RLIST(LIMIT),RLIST2(52), * VALP(21,LIMIT),VALN(21,LIMIT),LP(LIMIT),LN(LIMIT), * VP1(21),VP2(21),VN1(21),VN2(21) C EXTERNAL F C C MACHINE DEPENDENT CONSTANTS C --------------------------- C C EPMACH IS THE LARGEST RELATIVE SPACING. C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. C OFLOW IS THE LARGEST POSITIVE MAGNITUDE. C EPMACH = SPMPAR(1) UFLOW = SPMPAR(2) OFLOW = SPMPAR(3) C C TEST ON VALIDITY OF PARAMETERS C ------------------------------ LAST = 0 RESULT = 0.0 ABSERR = 0.0 ALIST(1) = A BLIST(1) = B RLIST(1) = 0.0 ELIST(1) = 0.0 IER = 6 IF (EPSABS .LT. 0.0 .OR. EPSREL.LT. 0.0) GO TO 999 IER = 0 RERR = AMAX1(EPSREL, 50.0*EPMACH) C C FIRST APPROXIMATION TO THE INTEGRAL C ----------------------------------- C IERRO = 0 LP(1) = 1 LN(1) = 1 VALP(1,1) = F((A + B)*0.5) VALN(1,1) = VALP(1,1) CALL QXLQM (F,A,B,RESULT,ABSERR,DEFABS,RESABS, * VALP(1,1),VALN(1,1),LP(1),LN(1),2, * EPMACH,UFLOW,OFLOW) C C TEST ON ACCURACY. C DRES = ABS(RESULT) ERRBND = AMAX1(EPSABS,RERR*DRES) LAST = 1 RLIST(1) = RESULT ELIST(1) = ABSERR IORD(1) = 1 IF (ABSERR .LE. 100.0*EPMACH*DEFABS .AND. ABSERR .GT. * ERRBND) IER = 2 IF (LIMIT .EQ. 1) IER = 1 IF (IER .NE. 0 .OR. (ABSERR.LE.ERRBND.AND.ABSERR.NE.RESABS) .OR. * ABSERR .EQ. 0.0) GO TO 999 C C INITIALIZATION C -------------- C RLIST2(1) = RESULT ERRMAX = ABSERR MAXERR = 1 AREA = RESULT ERRSUM = ABSERR ABSERR = OFLOW NRMAX = 1 NRES = 0 NUMRL2 = 2 KTMIN = 0 EXTRAP = .FALSE. NOEXT = .FALSE. IROFF1 = 0 IROFF2 = 0 IROFF3 = 0 KSGN = -1 IF (DRES .GE. (1.0 - 50.0*EPMACH)*DEFABS) KSGN = 1 T = 1.0 + 100.0*EPMACH C C MAIN DO-LOOP C ------------ C DO 90 LAST = 2,LIMIT C C BISECT THE SUBINTERVAL WITH THE NRMAX-TH LARGEST ERROR C ESTIMATE. C A1 = ALIST(MAXERR) B1 = 0.5*(ALIST(MAXERR) + BLIST(MAXERR)) A2 = B1 B2 = BLIST(MAXERR) ERLAST = ERRMAX CALL QXRRD(F,VALN(1,MAXERR),LN(MAXERR),B1,A1,VN1,VP1,LN1,LP1) CALL QXLQM(F,A1,B1,AREA1,ERROR1,RESABS,DEFAB1,VP1,VN1,LP1,LN1, * 2,EPMACH,UFLOW,OFLOW) CALL QXRRD(F,VALP(1,MAXERR),LP(MAXERR),A2,B2,VP2,VN2,LP2,LN2) CALL QXLQM(F,A2,B2,AREA2,ERROR2,RESABS,DEFAB2,VP2,VN2,LP2,LN2, * 2,EPMACH,UFLOW,OFLOW) C C IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL C AND ERROR AND TEST FOR ACCURACY. C AREA12 = AREA1 + AREA2 ERRO12 = ERROR1 + ERROR2 ERRSUM = ERRSUM + ERRO12 - ERRMAX AREA = AREA + AREA12 - RLIST(MAXERR) IF (DEFAB1 .EQ. ERROR1 .OR. DEFAB2 .EQ. ERROR2) GO TO 15 IF (ABS(RLIST(MAXERR) - AREA12) .GT. 0.1E-04*ABS(AREA12) * .OR. ERRO12 .LT. 0.99*ERRMAX) GO TO 10 IF (EXTRAP) IROFF2 = IROFF2 + 1 IF (.NOT.EXTRAP) IROFF1 = IROFF1 + 1 10 IF (LAST.GT.10 .AND. ERRO12.GT.ERRMAX) IROFF3 = IROFF3 + 1 15 RLIST(MAXERR) = AREA1 RLIST(LAST) = AREA2 ERRBND = AMAX1(EPSABS,RERR*ABS(AREA)) C C TEST FOR ROUNDOFF ERROR AND EVENTUALLY SET ERROR FLAG. C IF (IROFF1 + IROFF2 .GE. 10 .OR. IROFF3 .GE. 20) IER = 2 IF (IROFF2 .GE. 5) IERRO = 3 C C SET ERROR FLAG IN THE CASE THAT THE NUMBER OF SUBINTERVALS C EQUALS LIMIT. C IF (LAST .EQ. LIMIT) IER = 1 C C SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR C AT A POINT OF THE INTEGRATION RANGE. C IF (AMAX1(ABS(A1),ABS(B2)) .LE. * T*(ABS(A2) + 1.E+03*UFLOW)) IER = 4 C C APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. C IF (ERROR2 .GT. ERROR1) GO TO 20 ALIST(LAST) = A2 BLIST(MAXERR) = B1 BLIST(LAST) = B2 ELIST(MAXERR) = ERROR1 ELIST(LAST) = ERROR2 CALL QXCPY(VALP(1,MAXERR),VP1,LP1) LP(MAXERR) = LP1 CALL QXCPY(VALN(1,MAXERR),VN1,LN1) LN(MAXERR) = LN1 CALL QXCPY(VALP(1,LAST),VP2,LP2) LP(LAST) = LP2 CALL QXCPY(VALN(1,LAST),VN2,LN2) LN(LAST) = LN2 GO TO 30 C 20 ALIST(MAXERR) = A2 ALIST(LAST) = A1 BLIST(LAST) = B1 RLIST(MAXERR) = AREA2 RLIST(LAST) = AREA1 ELIST(MAXERR) = ERROR2 ELIST(LAST) = ERROR1 CALL QXCPY(VALP(1,MAXERR),VP2,LP2) LP(MAXERR) = LP2 CALL QXCPY(VALN(1,MAXERR),VN2,LN2) LN(MAXERR) = LN2 CALL QXCPY(VALP(1,LAST),VP1,LP1) LP(LAST) = LP1 CALL QXCPY(VALN(1,LAST),VN1,LN1) LN(LAST) = LN1 C C CALL SUBROUTINE QPSRT TO MAINTAIN THE DESCENDING ORDERING C IN THE LIST OF ERROR ESTIMATES AND SELECT THE SUBINTERVAL C WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE BISECTED NEXT). C 30 CALL QPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX) C ***JUMP OUT OF DO-LOOP IF(ERRSUM .LE. ERRBND) GO TO 115 C ***JUMP OUT OF DO-LOOP IF (IER .NE. 0) GO TO 100 IF (LAST .EQ. 2) GO TO 80 IF (NOEXT) GO TO 90 ERLARG = ERLARG - ERLAST IF (ABS(B1 - A1) .GT. SMALL) ERLARG = ERLARG + ERRO12 IF (EXTRAP) GO TO 40 C C TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE C SMALLEST INTERVAL. C IF (ABS(BLIST(MAXERR) - ALIST(MAXERR)) .GT. SMALL) GO TO 90 EXTRAP = .TRUE. NRMAX = 2 C C THE BOUND 0.3*ERTEST HAS BEEN INTRODUCED TO PERFORM A C MORE CAUTIOUS EXTRAPOLATION THAN IN THE ORIGINAL DQAGSE C ROUTINE C 40 IF (IERRO .EQ. 3 .OR. ERLARG .LE. 0.3*ERTEST) GO TO 60 C C THE SMALLEST INTERVAL HAS THE LARGEST ERROR. C BEFORE BISECTING DECREASE THE SUM OF THE ERRORS OVER THE C LARGER INTERVALS (ERLARG) AND PERFORM EXTRAPOLATION. C ID = NRMAX JUPBND = LAST IF (LAST .GT. (2 + LIMIT/2)) JUPBND = LIMIT + 3 - LAST DO 50 K = ID,JUPBND MAXERR = IORD(NRMAX) ERRMAX = ELIST(MAXERR) C ***JUMP OUT OF DO-LOOP IF(ABS(BLIST(MAXERR) - ALIST(MAXERR)) .GT. SMALL) GO TO 90 NRMAX = NRMAX + 1 50 CONTINUE C C PERFORM EXTRAPOLATION. C 60 NUMRL2 = NUMRL2 + 1 RLIST2(NUMRL2) = AREA CALL QELG (NUMRL2,RLIST2,RESEPS,ABSEPS,RES3LA,NRES, * EPMACH,OFLOW) KTMIN = KTMIN + 1 IF (KTMIN .GT. 5 .AND. ABSERR .LT. 0.1E-02*ERRSUM) IER = 5 IF (ABSEPS .GE. ABSERR) GO TO 70 KTMIN = 0 ABSERR = ABSEPS RESULT = RESEPS CORREC = ERLARG ERTEST = AMAX1(EPSABS,RERR*ABS(RESEPS)) C ***JUMP OUT OF DO-LOOP IF (ABSERR .LE. ERTEST) GO TO 100 C C PREPARE BISECTION OF THE SMALLEST INTERVAL. C 70 IF (NUMRL2 .EQ. 1) NOEXT = .TRUE. IF (IER .EQ. 5) GO TO 100 MAXERR = IORD(1) ERRMAX = ELIST(MAXERR) NRMAX = 1 EXTRAP = .FALSE. SMALL = SMALL*0.5 ERLARG = ERRSUM GO TO 90 80 SMALL = ABS(B - A)*0.375 ERLARG = ERRSUM ERTEST = ERRBND RLIST2(2) = AREA 90 CONTINUE C C SET FINAL RESULT AND ERROR ESTIMATE. C ------------------------------------ C 100 IF (ABSERR .EQ. OFLOW) GO TO 115 IF (IER + IERRO .EQ. 0) GO TO 110 IF (IERRO .EQ. 3) ABSERR = ABSERR + CORREC IF (IER .EQ. 0) IER = 3 IF (RESULT .NE. 0.0 .AND. AREA .NE. 0.0) GO TO 105 IF (ABSERR .GT. ERRSUM) GO TO 115 IF (AREA .EQ. 0.0) GO TO 130 GO TO 110 105 IF (ABSERR/ABS(RESULT) .GT. ERRSUM/ABS(AREA)) GO TO 115 C C TEST ON DIVERGENCE. C 110 IF(KSGN.EQ.(-1).AND.AMAX1(ABS(RESULT),ABS(AREA)).LE. * DEFABS*0.1E-01) GO TO 130 IF(0.1E-01.GT.(RESULT/AREA).OR.(RESULT/AREA).GT.0.1E+03 * .OR.ERRSUM.GT.ABS(AREA)) IER = 6 GO TO 130 C C COMPUTE GLOBAL INTEGRAL SUM. C 115 RESULT = 0.0 DO 120 K = 1,LAST RESULT = RESULT + RLIST(K) 120 CONTINUE ABSERR = ERRSUM 130 IF (IER .GT. 2) IER = IER - 1 999 RETURN END SUBROUTINE QXCPY (A, B, L) C C TO COPY THE REAL VECTOR B OF LENGTH L I N T O C THE REAL VECTOR A OF LENGTH L C INTEGER L REAL A(L),B(L) C DO 10 I = 1,L 10 A(I) = B(I) RETURN END SUBROUTINE QXLQM (F,A,B,RESULT,ABSERR,RESABS,RESASC,VR,VS,LR,LS, * KEY,EPMACH,UFLOW,OFLOW) C C TO COMPUTE I = INTEGRAL OF F OVER (A,B), WITH ERROR C ESTIMATE C J = INTEGRAL OF ABS(F) OVER (A,B) C C PARAMETERS C ON ENTRY C F - REAL C FUNCTION SUBPROGRAM DEFINING THE INTEGRAND C FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE C DECLARED E X T E R N A L IN THE DRIVER PROGRAM. C C A - REAL C LOWER LIMIT OF INTEGRATION C C B - REAL C UPPER LIMIT OF INTEGRATION C C VR - REAL C VECTOR OF LENGTH LR CONTAINING THE C SAVED FUNCTIONAL VALUES OF POSITIVE ABSCISSAS C C VS - REAL C VECTOR OF LENGTH LS CONTAINING THE C SAVED FUNCTIONAL VALUES OF NEGATIVE ABSCISSAS C C LR - INTEGER C LS NUMBER OF ELEMENTS IN C VR,VS RESPECTIVELY C C KEY - INTEGER C KEY FOR CHOICE OF LOCAL INTEGRATION RULE C RMS FORMULAS ARE USED WITH C 13 - 19 POINTS IF KEY.LT.1, C 13 - 19 - (27) POINTS IF KEY = 1, C 13 - 19 - (27) - (41) POINTS IF KEY = 2, C 19 - 27 - (41) POINTS IF KEY = 3, C 27 - 41 POINTS IF KEY.GT.3. C C (RULES) USED IF THE FUNCTION APPEARS C ENOUGH REGULAR C C EPMACH - REAL C THE RELATIVE PRECISION OF THE FLOATING C ARITHMETIC BEING USED. C C UFLOW - REAL C THE SMALLEST POSITIVE MAGNITUDE. C C OFLOW - REAL C THE LARGEST POSITIVE MAGNITUDE. C C ON RETURN C RESULT - REAL C APPROXIMATION TO THE INTEGRAL I C C ABSERR - REAL C ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR, C WHICH SHOULD NOT EXCEED ABS(I-RESULT) C C RESABS - REAL C APPROXIMATION TO THE INTEGRAL J C C RESASC - REAL C APPROXIMATION TO THE INTEGRAL OF ABS(F-I/(B-A)) C OVER (A,B) C C VR - REAL C VECTOR OF LENGTH LR CONTAINING THE C SAVED FUNCTIONAL VALUES OF POSITIVE ABSCISSAS C C VS - REAL C VECTOR OF LENGTH LS CONTAINING THE C SAVED FUNCTIONAL VALUES OF NEGATIVE ABSCISSAS C C LR - INTEGER C LS NUMBER OF ELEMENTS IN C VR,VS RESPECTIVELY C C***ROUTINES CALLED QXRUL C REAL F,A,B,RESULT,ABSERR,RESABS,RESASC,T, * EPMACH,OFLOW,UFLOW,RESG,RESK,ERROLD,VR(21),VS(21) INTEGER K,K0,K1,K2,KEY,KEY1,LR,LS EXTERNAL F C KEY1 = MAX0(KEY , 0) KEY1 = MIN0(KEY1, 4) K0 = MAX0(KEY1-2,0) K1 = K0 + 1 K2 = MIN0(KEY1+1,3) C CALL QXRUL (F,A,B,RESG,RESABS,RESASC,K0,K1,VR,VS,LR,LS) ERROLD = OFLOW T = 10.0*EPMACH DO 10 K = K1,K2 CALL QXRUL (F,A,B,RESK,RESABS,RESASC,K,K1,VR,VS,LR,LS) RESULT = RESK ABSERR = ABS(RESK - RESG) IF (RESASC .NE. 0.0 .AND. ABSERR .NE. 0.0) * ABSERR = RESASC*AMIN1(1.0,(200.0*ABSERR/RESASC)**1.5) IF (RESABS .GT. UFLOW/T) ABSERR = AMAX1(T*RESABS,ABSERR) RESG = RESK IF (ABSERR .GT. ERROLD*0.16) GO TO 3000 IF (ABSERR .LT. 1000.0*EPMACH*RESABS) GO TO 3000 ERROLD = ABSERR 10 CONTINUE 3000 CONTINUE RETURN END SUBROUTINE QXRUL (F,XL,XU,Y,YA,YM,KE,K1,FV1,FV2,L1,L2) C C TO COMPUTE I = INTEGRAL OF F OVER (A,B), WITH ERROR C ESTIMATE C AND CONDITIONALLY COMPUTE C J = INTEGRAL OF ABS(F) OVER (A,B) C BY USING AN RMS RULE C PARAMETERS C ON ENTRY C F - REAL C FUNCTION SUBPROGRAM DEFINING THE INTEGRAND C FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE C DECLARED E X T E R N A L IN THE DRIVER PROGRAM. C C XL - REAL C LOWER LIMIT OF INTEGRATION C C XU - REAL C UPPER LIMIT OF INTEGRATION C C KE - INTEGER C KEY FOR CHOICE OF LOCAL INTEGRATION RULE C AN RMS RULE IS USED WITH C 13 POINTS IF KE = 2, C 19 POINTS IF KE = 3, C 27 POINTS IF KE = 4, C 42 POINTS IF KE = 5 C C K1 INTEGER C VALUE OF KEY FOR WHICH THE ADDITIONAL ESTIMATES C YA, YM ARE TO BE COMPUTED C C FV1 - REAL C VECTOR CONTAINING L1 C SAVED FUNCTIONAL VALUES OF POSITIVE ABSCISSAS C C FV2 - REAL C VECTOR CONTAINING L2 C SAVED FUNCTIONAL VALUES OF NEGATIVE ABSCISSAS C C L1 - INTEGER C L2 NUMBER OF ELEMENTS IN FV1,FV2 RESPECTIVELY C C ON RETURN C Y - REAL C APPROXIMATION TO THE INTEGRAL I C RESULT IS COMPUTED BY APPLYING THE C REQUESTED RMS RULE C C YA - REAL C IF KEY = K1 APPROXIMATION TO THE INTEGRAL J C ELSE UNCHANGED C C YM - REAL C IF KEY = K1 APPROXIMATION TO THE INTEGRAL OF C ABS(F-I/(XU-XL) OVER (XL,XU) C ELSE UNCHANGED C C FV1 - REAL C VECTOR CONTAINING L1 C SAVED FUNCTIONAL VALUES OF POSITIVE ABSCISSAS C C FV2 - REAL C VECTOR CONTAINING L2 C SAVED FUNCTIONAL VALUES OF NEGATIVE ABSCISSAS C C L1 - INTEGER C L2 NUMBER OF ELEMENTS IN FV1,FV2 RESPECTIVELY C C------------------------ REAL F,XL,XU,LDL,Y,YA,YM,Y2,XX(41),WW(52), * FV1(21),FV2(21),AA,BB,C INTEGER ISTART(4),LEN(4),J,KE,K1,L1,L2 EXTERNAL F C------------------------ DATA ISTART(1)/0/, ISTART(2)/7/, ISTART(3)/17/, ISTART(4)/31/ DATA LEN(1)/7/, LEN(2)/10/, LEN(3)/14/, LEN(4)/21/ C------------------------ DATA XX( 1)/.0 / DATA XX( 2)/.25000000000000000000E+00/ DATA XX( 3)/.50000000000000000000E+00/ DATA XX( 4)/.75000000000000000000E+00/ DATA XX( 5)/.87500000000000000000E+00/ DATA XX( 6)/.93750000000000000000E+00/ DATA XX( 7)/.10000000000000000000E+01/ DATA XX( 8)/.37500000000000000000E+00/ DATA XX( 9)/.62500000000000000000E+00/ DATA XX(10)/.96875000000000000000E+00/ DATA XX(11)/.12500000000000000000E+00/ DATA XX(12)/.68750000000000000000E+00/ DATA XX(13)/.81250000000000000000E+00/ DATA XX(14)/.98437500000000000000E+00/ DATA XX(15)/.18750000000000000000E+00/ DATA XX(16)/.31250000000000000000E+00/ DATA XX(17)/.43750000000000000000E+00/ DATA XX(18)/.56250000000000000000E+00/ DATA XX(19)/.84375000000000000000E+00/ DATA XX(20)/.90625000000000000000E+00/ DATA XX(21)/.99218750000000000000E+00/ C NUMBER OF NODES 13 DATA WW(1)/1.303262173284849021810473057638590518409112513421E-1/ DATA WW(2)/2.390632866847646220320329836544615917290026806242E-1/ DATA WW(3)/2.630626354774670227333506083741355715758124943143E-1/ DATA WW(4)/2.186819313830574175167853094864355208948886875898E-1/ DATA WW(5)/2.757897646642836865859601197607471574336674206700E-2/ DATA WW(6)/1.055750100538458443365034879086669791305550493830E-1/ DATA WW(7)/1.571194260595182254168429283636656908546309467968E-2/ C NUMBER OF NODES 19 DATA WW(8)/1.298751627936015783241173611320651866834051160074E-1/ DATA WW(9)/2.249996826462523640447834514709508786970828213187E-1/ DATA WW(15)/5.542699233295875168406783695143646338274805359780E-2/ DATA WW(10)/1.680415725925575286319046726692683040162290325505E-1/ DATA WW(16)/9.986735247403367525720377847755415293097913496236E-2/ DATA WW(11)/1.415567675701225879892811622832845252125600939627E-1/ DATA WW(12)/1.006482260551160175038684459742336605269707889822E-1/ DATA WW(13)/2.510604860724282479058338820428989444699235030871E-2/ DATA WW(17)/4.507523056810492466415880450799432587809828791196E-2/ DATA WW(14)/9.402964360009747110031098328922608224934320397592E-3/ C NUMBER OF NODES 27 DATA WW(18)/6.300942249647773931746170540321811473310938661469E-2/ DATA WW(28)/1.239572396231834242194189674243818619042280816640E-1/ DATA WW(19)/1.261383225537664703012999637242003647020326905948E-1/ DATA WW(25)/1.235837891364555000245004813294817451524633100256E-1/ DATA WW(20)/1.273864433581028272878709981850307363453523117880E-1/ DATA WW(26)/1.148933497158144016800199601785309838604146040215E-1/ DATA WW(29)/2.501306413750310579525950767549691151739047969345E-2/ DATA WW(21)/8.576500414311820514214087864326799153427368592787E-2/ DATA WW(30)/4.915957918146130094258849161350510503556792927578E-2/ DATA WW(22)/7.102884842310253397447305465997026228407227220665E-2/ DATA WW(23)/5.026383572857942403759829860675892897279675661654E-2/ DATA WW(27)/1.252575774226122633391477702593585307254527198070E-2/ DATA WW(31)/2.259167374956474713302030584548274729936249753832E-2/ DATA WW(24)/4.683670010609093810432609684738393586390722052124E-3/ C NUMBER OF NODES 41 DATA WW(32)/6.362762978782724559269342300509058175967124446839E-2/ DATA WW(42)/1.187141856692283347609436153545356484256869129472E-1/ DATA WW(46)/1.533126874056586959338368742803997744815413565014E-2/ DATA WW(33)/9.950065827346794643193261975720606296171462239514E-2/ DATA WW(47)/3.527159369750123100455704702965541866345781113903E-2/ DATA WW(39)/8.140326425945938045967829319725797511040878579808E-2/ DATA WW(48)/5.000556431653955124212795201196389006184693561679E-2/ DATA WW(34)/7.048220002718565366098742295389607994441704889441E-2/ DATA WW(49)/5.744164831179720106340717579281831675999717767532E-2/ DATA WW(40)/6.583213447600552906273539578430361199084485578379E-2/ DATA WW(43)/5.999947605385971985589674757013565610751028128731E-2/ DATA WW(35)/6.512297339398335645872697307762912795346716454337E-2/ DATA WW(44)/5.500937980198041736910257988346101839062581489820E-2/ DATA WW(50)/1.598823797283813438301248206397233634639162043386E-2/ DATA WW(36)/3.998229150313659724790527138690215186863915308702E-2/ DATA WW(51)/2.635660410220884993472478832884065450876913559421E-2/ DATA WW(37)/3.456512257080287509832054272964315588028252136044E-2/ DATA WW(41)/2.592913726450792546064232192976262988065252032902E-2/ DATA WW(45)/5.264422421764655969760271538981443718440340270116E-3/ DATA WW(52)/1.196003937945541091670106760660561117114584656319E-2/ DATA WW(38)/2.212167975884114432760321569298651047876071264944E-3/ C------------------------ K = KE + 1 IS = ISTART(K) KS = LEN(K) LDL = XU - XL BB = LDL*0.5 AA = XL + BB C Y = 0.0 DO 10 I = 1,KS C = BB*XX(I) IF (I .GT. L1) FV1(I) = F(AA + C) IF (I .GT. L2) FV2(I) = F(AA - C) J = IS + I Y = Y + (FV1(I) + FV2(I))*WW(J) 10 CONTINUE C Y2 = Y Y = Y*BB IF (L1 .LT. KS) L1 = KS IF (L2 .LT. KS) L2 = KS IF (KE .NE. K1) RETURN C YA = 0.0 DO 20 I = 1,KS J = IS + I YA = YA + (ABS(FV1(I)) + ABS(FV2(I)))*WW(J) 20 CONTINUE YA = YA*ABS(BB) C Y2 = Y2*0.5 YM = 0.0 DO 30 I = 1,KS J = IS + I YM = YM + (ABS(FV1(I) - Y2) + ABS(FV2(I) - Y2))*WW(J) 30 CONTINUE YM = YM*ABS(BB) RETURN END SUBROUTINE QXRRD (F,Z,LZ,XL,XU,R,S,LR,LS) C C TO REORDER THE COMPUTED FUNCTIONAL VALUES BEFORE C THE BISECTION OF AN INTERVAL C C PARAMETERS C ON ENTRY C F - REAL C FUNCTION SUBPROGRAM DEFINING THE INTEGRAND C FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE C DECLARED E X T E R N A L IN THE DRIVER PROGRAM. C C XL - REAL C LOWER LIMIT OF INTERVAL C C XU - REAL C UPPER LIMIT OF INTERVAL C C Z - REAL C VECTOR CONTAINING LZ C SAVED FUNCTIONAL VALUES C C LZ - INTEGER C NUMBER OF ELEMENTS IN LZ C C ON RETURN C R - REAL C S VECTORS CONTAINING LR, LS C SAVED FUNCTIONAL VALUES FOR THE NEW INTERVALS C C LR - INTEGER C LS NUMBER OF ELEMENTES IN R,S RESPECTIVELY C C***ROUTINES CALLED F C REAL F,R,S,Z,XU,XL,DLEN,CENTR INTEGER LR,LS,LZ DIMENSION R(21),S(21),Z(21) C DLEN = (XU - XL)*0.5 CENTR = XL + DLEN R(1) = Z(3) R(2) = Z(9) R(3) = Z(4) R(4) = Z(5) R(5) = Z(6) R(6) = Z(10) R(7) = Z(7) S(1) = Z(3) S(2) = Z(8) S(3) = Z(2) S(7) = Z(1) IF (LZ .GT. 11) GO TO 10 C R(8) = F(CENTR + DLEN*0.375) R(9) = F(CENTR + DLEN*0.625) R(10) = F(CENTR + DLEN*0.96875) LR = 10 IF (LZ .NE. 11) S(4) = F(CENTR - DLEN*0.75) IF (LZ .EQ. 11) S(4) = Z(11) S(5) = F(CENTR - DLEN*0.875) S(6) = F(CENTR - DLEN*0.9375) S(8) = F(CENTR - DLEN*0.375) S(9) = F(CENTR - DLEN*0.625) S(10) = F(CENTR - DLEN*0.96875) LS = 10 RETURN C 10 R(8) = Z(12) R(9) = Z(13) R(10) = Z(14) LR = 10 S(4) = Z(11) S(5) = F(CENTR - DLEN*0.875) S(6) = F(CENTR - DLEN*0.9375) IF (LZ .GT. 14) GO TO 20 S(8) = F(CENTR - DLEN*0.375) S(9) = F(CENTR - DLEN*0.625) S(10) = F(CENTR - DLEN*0.96875) LS = 10 RETURN C 20 R(11) = Z(18) R(12) = Z(19) R(13) = Z(20) R(14) = Z(21) LR = 14 S(8) = Z(16) S(9) = Z(15) S(10) = F(CENTR - DLEN*0.96875) S(11) = Z(17) LS = 11 RETURN END SUBROUTINE DQAGS (F, A, B, EPSABS, EPSREL, RESULT, ABSERR, * NEVAL, IER, LIMIT, LENW, LAST, IWORK, WORK) C----------------------------------------------------------------------- C C DOUBLE PRECISION COMPUTATION OF A DEFINITE INTEGRAL C C----------------------------------------------------------------------- C C PURPOSE C THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO A GIVEN C DEFINITE INTEGRAL I = INTEGRAL OF F OVER (A,B), C HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY C ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). C C PARAMETERS C ON ENTRY C F - DOUBLE PRECISION C FUNCTION SUBPROGRAM DEFINING THE INTEGRAND C FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE C DECLARED E X T E R N A L IN THE DRIVER PROGRAM. C C A - DOUBLE PRECISION C LOWER LIMIT OF INTEGRATION C C B - DOUBLE PRECISION C UPPER LIMIT OF INTEGRATION C C EPSABS - DOUBLE PRECISION C ABSOLUTE ACCURACY REQUESTED C C EPSREL - DOUBLE PRECISION C RELATIVE ACCURACY REQUESTED C C ON RETURN C RESULT - DOUBLE PRECISION C APPROXIMATION TO THE INTEGRAL C C ABSERR - DOUBLE PRECISION C ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR, C WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT) C C NEVAL - INTEGER C NUMBER OF INTEGRAND EVALUATIONS C C IER - INTEGER C IER = 0 NORMAL AND RELIABLE TERMINATION OF THE C ROUTINE. IT IS ASSUMED THAT THE REQUESTED C ACCURACY HAS BEEN ACHIEVED. C IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE C THE ESTIMATES FOR INTEGRAL AND ERROR ARE C LESS RELIABLE. IT IS ASSUMED THAT THE C REQUESTED ACCURACY HAS NOT BEEN ACHIEVED. C C IER = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED C HAS BEEN ACHIEVED. ONE CAN ALLOW MORE SUB- C DIVISIONS BY INCREASING THE VALUE OF C LIMIT (AND TAKING THE ACCORDING C DIMENSION ADJUSTMENTS INTO ACCOUNT). C HOWEVER, IF THIS YIELDS NO IMPROVEMENT C IT IS ADVISED TO ANALYZE THE INTEGRAND C IN ORDER TO DETERMINE THE INTEGRATION C DIFFICULTIES. IF THE POSITION OF A C LOCAL DIFFICULTY CAN BE DETERMINED (E.G. C SINGULARITY, DISCONTINUITY WITHIN THE C INTERVAL) ONE WILL PROBABLY GAIN FROM C SPLITTING UP THE INTERVAL AT THIS POINT C AND CALLING THE INTEGRATOR ON THE SUB- C RANGES. IF POSSIBLE, AN APPROPRIATE C SPECIAL-PURPOSE INTEGRATOR SHOULD BE USED, C WHICH IS DESIGNED FOR HANDLING THE TYPE C OF DIFFICULTY INVOLVED. C = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS DETEC- C TED, WHICH PREVENTS THE REQUESTED C TOLERANCE FROM BEING ACHIEVED. C THE ERROR MAY BE UNDER-ESTIMATED. C = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR C OCCURS AT SOME POINTS OF THE INTEGRATION C INTERVAL. C = 4 THE ALGORITHM DOES NOT CONVERGE. C IT IS PRESUMED THAT THE REQUESTED C TOLERANCE CANNOT BE ACHIEVED, AND THAT THE C RETURNED RESULT IS THE BEST WHICH CAN BE C OBTAINED. C = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR C SLOWLY CONVERGENT. IT MUST BE NOTED C THAT DIVERGENCE CAN OCCUR WITH ANY OTHER C VALUE OF IER. C = 6 THE INPUT IS INVALID BECAUSE EPSABS C OR EPSREL IS NEGATIVE, LIMIT .LT. 1, C OR LENW .LT. 4 * LIMIT. C RESULT, ABSERR, NEVAL, LAST ARE C SET TO ZERO. C C DIMENSIONING PARAMETERS C LIMIT - INTEGER C DIMENSIONING PARAMETER FOR IWORK C LIMIT DETERMINES THE MAXIMUM NUMBER C OF SUBINTERVALS IN THE PARTITION OF THE GIVEN C INTEGRATION INTERVAL (A,B), LIMIT.GE.1. C IF LIMIT.LT.1, THE ROUTINE WILL END WITH C IER = 6. C C LENW - INTEGER C DIMENSIONING PARAMETER FOR WORK C LENW MUST BE AT LEAST LIMIT*4. C IF LENW.LT.LIMIT*4, THE ROUTINE WILL END C WITH IER = 6. C C LAST - INTEGER C ON RETURN, LAST EQUALS THE NUMBER OF C SUBINTERVALS PRODUCED IN THE SUBDIVISION C PROCESS, WHICH DETERMINES THE NUMBER OF C SIGNIFICANT ELEMENTS ACTUALLY IN THE WORK C ARRAYS. C C WORK ARRAYS C IWORK - INTEGER C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST K C ELEMENTS OF WHICH CONTAIN POINTERS C TO THE ERROR ESTIMATES OVER THE SUBINTERVALS C SUCH THAT WORK(LIMIT*3+IWORK(1)),... , C WORK(LIMIT*3+IWORK(K)) FORM A DECREASING C SEQUENCE, WITH K = LAST IF LAST.LE.(LIMIT/2+2), AND C K = LIMIT+1-LAST OTHERWISE C C WORK - DOUBLE PRECISION C VECTOR OF DIMENSION AT LEAST LENW C ON RETURN C WORK(1), ..., WORK(LAST) CONTAIN THE LEFT C END POINTS OF THE SUBINTERVALS IN THE C PARTITION OF (A,B), C WORK(LIMIT+1), ..., WORK(LIMIT+LAST) CONTAIN C THE RIGHT END POINTS, C WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) C CONTAIN THE INTEGRAL APPROXIMATIONS OVER C THE SUBINTERVALS, C WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST) C CONTAIN THE ERROR ESTIMATES. C C SUBROUTINES OR FUNCTIONS NEEDED C - DQAGSE C - DQK21 C - DQPSRT C - DQELG C - F (USER-PROVIDED FUNCTION) C - DPMPAR C C----------------------------------------------------------------------- DOUBLE PRECISION A,ABSERR,B,EPSABS,EPSREL,F,RESULT,WORK INTEGER IER,IWORK,LENW,LIMIT,L1,L2,L3,NEVAL C DIMENSION IWORK(LIMIT), WORK(LENW) EXTERNAL F C C CHECK VALIDITY OF LIMIT AND LENW. C IER = 6 NEVAL = 0 LAST = 0 RESULT = 0.D0 ABSERR = 0.D0 IF (LIMIT .LT. 1 .OR. LENW .LT. LIMIT*4) RETURN C C PREPARE CALL FOR DQAGSE. C L1 = LIMIT + 1 L2 = LIMIT + L1 L3 = LIMIT + L2 C CALL DQAGSE (F,A,B,EPSABS,EPSREL,LIMIT,RESULT,ABSERR,NEVAL, * IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST) RETURN END SUBROUTINE DQAGSE (F,A,B,EPSABS,EPSREL,LIMIT,RESULT,ABSERR, * NEVAL,IER,ALIST,BLIST,RLIST,ELIST,IORD,LAST) C----------------------------------------------------------------------- C C DOUBLE PRECISION COMPUTATION OF A DEFINITE INTEGRAL C C----------------------------------------------------------------------- C C PURPOSE C THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO A GIVEN C DEFINITE INTEGRAL I = INTEGRAL OF F OVER (A,B), C HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY C ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). C C PARAMETERS C ON ENTRY C F - DOUBLE PRECISION C FUNCTION SUBPROGRAM DEFINING THE INTEGRAND C FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE C DECLARED E X T E R N A L IN THE DRIVER PROGRAM. C C A - DOUBLE PRECISION C LOWER LIMIT OF INTEGRATION C C B - DOUBLE PRECISION C UPPER LIMIT OF INTEGRATION C C EPSABS - DOUBLE PRECISION C ABSOLUTE ACCURACY REQUESTED C C EPSREL - DOUBLE PRECISION C RELATIVE ACCURACY REQUESTED C C LIMIT - INTEGER C GIVES AN UPPERBOUND ON THE NUMBER OF C SUBINTERVALS IN THE PARTITION OF (A,B) C C ON RETURN C RESULT - DOUBLE PRECISION C APPROXIMATION TO THE INTEGRAL C C ABSERR - DOUBLE PRECISION C ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR, C WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT) C C NEVAL - INTEGER C NUMBER OF INTEGRAND EVALUATIONS C C IER - INTEGER C IER = 0 NORMAL AND RELIABLE TERMINATION OF THE C ROUTINE. IT IS ASSUMED THAT THE REQUESTED C ACCURACY HAS BEEN ACHIEVED. C IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE C THE ESTIMATES FOR INTEGRAL AND ERROR ARE C LESS RELIABLE. IT IS ASSUMED THAT THE C REQUESTED ACCURACY HAS NOT BEEN ACHIEVED. C C = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED C HAS BEEN ACHIEVED. ONE CAN ALLOW MORE SUB- C DIVISIONS BY INCREASING THE VALUE OF C LIMIT (AND TAKING THE ACCORDING C DIMENSION ADJUSTMENTS INTO ACCOUNT). C HOWEVER, IF THIS YIELDS NO IMPROVEMENT C IT IS ADVISED TO ANALYZE THE INTEGRAND C IN ORDER TO DETERMINE THE INTEGRATION C DIFFICULTIES. IF THE POSITION OF A C LOCAL DIFFICULTY CAN BE DETERMINED (E.G. C SINGULARITY, DISCONTINUITY WITHIN THE C INTERVAL) ONE WILL PROBABLY GAIN FROM C SPLITTING UP THE INTERVAL AT THIS POINT C AND CALLING THE INTEGRATOR ON THE SUB- C RANGES. IF POSSIBLE, AN APPROPRIATE C SPECIAL-PURPOSE INTEGRATOR SHOULD BE USED, C WHICH IS DESIGNED FOR HANDLING THE TYPE C OF DIFFICULTY INVOLVED. C = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS DETEC- C TED, WHICH PREVENTS THE REQUESTED C TOLERANCE FROM BEING ACHIEVED. C THE ERROR MAY BE UNDER-ESTIMATED. C = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR C OCCURS AT SOME POINTS OF THE INTEGRATION C INTERVAL. C = 4 THE ALGORITHM DOES NOT CONVERGE. C IT IS PRESUMED THAT THE REQUESTED C TOLERANCE CANNOT BE ACHIEVED, AND THAT THE C RETURNED RESULT IS THE BEST WHICH CAN BE C OBTAINED. C = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR C SLOWLY CONVERGENT. IT MUST BE NOTED C THAT DIVERGENCE CAN OCCUR WITH ANY OTHER C VALUE OF IER. C = 6 THE INPUT IS INVALID BECAUSE EPSABS C OR EPSREL IS NEGATIVE. C RESULT, ABSERR, NEVAL, LAST, RLIST(1), C IORD(1) AND ELIST(1) ARE SET TO ZERO. C ALIST(1) AND BLIST(1) ARE SET TO A AND B C RESPECTIVELY. C C ALIST - DOUBLE PRECISION C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST C LAST ELEMENTS OF WHICH ARE THE LEFT C END POINTS OF THE SUBINTERVALS IN THE PARTITION C OF THE GIVEN INTEGRATION RANGE (A,B) C C BLIST - DOUBLE PRECISION C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST C LAST ELEMENTS OF WHICH ARE THE RIGHT C END POINTS OF THE SUBINTERVALS IN THE PARTITION C OF THE GIVEN INTEGRATION RANGE (A,B) C C RLIST - DOUBLE PRECISION C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST C LAST ELEMENTS OF WHICH ARE THE INTEGRAL C APPROXIMATIONS ON THE SUBINTERVALS C C ELIST - DOUBLE PRECISION C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST C LAST ELEMENTS OF WHICH ARE THE MODULI C OF THE ABSOLUTE ERROR ESTIMATES ON THE C SUBINERVALS C C IORD - INTEGER C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST K C ELEMENTS OF WHICH ARE POINTERS TO THE ERROR C ESTIMATES OVER THE SUBINTERVALS, SUCH C THAT ELIST(IORD(1)), ..., ELIST(IORD(K)) C FORM A DECREASING SEQUENCE, WITH K = LAST C IF LAST.LE.(LIMIT/2+2), AND K = LIMIT+1-LAST C OTHERWISE C C LAST - INTEGER C NUMBER OF SUBINTERVALS ACTUALLY PRODUCED IN THE C SUBDIVISION PROCESS C C SUBROUTINES OR FUNCTIONS NEEDED C - DQK21 C - DQPSRT C - DQELG C - F (USER-PROVIDED FUNCTION) C - DPMPAR C C----------------------------------------------------------------------- DOUBLE PRECISION A,ABSEPS,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2, * A1,A2,B,BLIST,B1,B2,CORREC,DEFABS,DEFAB1,DEFAB2,DPMPAR, * DRES,ELIST,EPMACH,EPSABS,EPSREL,ERLARG,ERLAST,ERRBND, * ERRMAX,ERROR1,ERROR2,ERRO12,ERRSUM,ERTEST,F,OFLOW,RERR,RESABS, * RESEPS,RESULT,RES3LA,RLIST,RLIST2,SMALL,T,UFLOW INTEGER ID,IER,IERRO,IORD,IROFF1,IROFF2,IROFF3,JUPBND,K,KSGN, * KTMIN,LAST,LIMIT,MAXERR,NEVAL,NRES,NRMAX,NUMRL2 LOGICAL EXTRAP,NOEXT C DIMENSION ALIST(LIMIT),BLIST(LIMIT),ELIST(LIMIT),IORD(LIMIT), * RES3LA(3),RLIST(LIMIT),RLIST2(52) C EXTERNAL F C C THE DIMENSION OF RLIST2 IS DETERMINED BY THE VALUE OF C LIMEXP IN SUBROUTINE DQELG (RLIST2 SHOULD BE OF DIMENSION C (LIMEXP+2) AT LEAST). C C LIST OF MAJOR VARIABLES C ----------------------- C C ALIST - LIST OF LEFT END POINTS OF ALL SUBINTERVALS C CONSIDERED UP TO NOW C BLIST - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS C CONSIDERED UP TO NOW C RLIST(I) - APPROXIMATION TO THE INTEGRAL OVER C (ALIST(I),BLIST(I)) C RLIST2 - ARRAY OF DIMENSION AT LEAST LIMEXP+2 C CONTAINING THE PART OF THE EPSILON TABLE C WHICH IS STILL NEEDED FOR FURTHER COMPUTATIONS C ELIST(I) - ERROR ESTIMATE APPLYING TO RLIST(I) C MAXERR - POINTER TO THE INTERVAL WITH LARGEST ERROR C ESTIMATE C ERRMAX - ELIST(MAXERR) C ERLAST - ERROR ON THE INTERVAL CURRENTLY SUBDIVIDED C (BEFORE THAT SUBDIVISION HAS TAKEN PLACE) C AREA - SUM OF THE INTEGRALS OVER THE SUBINTERVALS C ERRSUM - SUM OF THE ERRORS OVER THE SUBINTERVALS C ERRBND - REQUESTED ACCURACY MAX(EPSABS,EPSREL* C ABS(RESULT)) C *****1 - VARIABLE FOR THE LEFT INTERVAL C *****2 - VARIABLE FOR THE RIGHT INTERVAL C LAST - INDEX FOR SUBDIVISION C NRES - NUMBER OF CALLS TO THE EXTRAPOLATION ROUTINE C NUMRL2 - NUMBER OF ELEMENTS CURRENTLY IN RLIST2. IF AN C APPROPRIATE APPROXIMATION TO THE COMPOUNDED C INTEGRAL HAS BEEN OBTAINED IT IS PUT IN C RLIST2(NUMRL2) AFTER NUMRL2 HAS BEEN INCREASED C BY ONE. C SMALL - LENGTH OF THE SMALLEST INTERVAL CONSIDERED C UP TO NOW, MULTIPLIED BY 1.5 C ERLARG - SUM OF THE ERRORS OVER THE INTERVALS LARGER C THAN THE SMALLEST INTERVAL CONSIDERED UP TO NOW C EXTRAP - LOGICAL VARIABLE DENOTING THAT THE ROUTINE C IS ATTEMPTING TO PERFORM EXTRAPOLATION C I.E. BEFORE SUBDIVIDING THE SMALLEST INTERVAL C WE TRY TO DECREASE THE VALUE OF ERLARG. C NOEXT - LOGICAL VARIABLE DENOTING THAT EXTRAPOLATION C IS NO LONGER ALLOWED (TRUE VALUE) C C MACHINE DEPENDENT CONSTANTS C --------------------------- C C EPMACH IS THE LARGEST RELATIVE SPACING. C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. C OFLOW IS THE LARGEST POSITIVE MAGNITUDE. C EPMACH = DPMPAR(1) UFLOW = DPMPAR(2) OFLOW = DPMPAR(3) C C CHECK EPSABS AND EPSREL C ----------------------- C NEVAL = 0 LAST = 0 RESULT = 0.D0 ABSERR = 0.D0 ALIST(1) = A BLIST(1) = B RLIST(1) = 0.D0 ELIST(1) = 0.D0 IER = 6 IF (EPSABS .LT. 0.D0 .OR. EPSREL .LT. 0.D0) GO TO 999 IER = 0 RERR = DMAX1(EPSREL, 50.D0*EPMACH, 0.5D-28) C C FIRST APPROXIMATION TO THE INTEGRAL C ----------------------------------- C IERRO = 0 CALL DQK21 (F, A, B, RESULT, ABSERR, DEFABS, RESABS, * EPMACH, UFLOW, ID) IF (ID .NE. 0) GO TO 999 NEVAL = 21 C C TEST ON ACCURACY. C DRES = DABS(RESULT) ERRBND = DMAX1(EPSABS,RERR*DRES) LAST = 1 RLIST(1) = RESULT ELIST(1) = ABSERR IORD(1) = 1 IF (ABSERR .LE. 100.D0*EPMACH*DEFABS .AND. ABSERR .GT. * ERRBND) IER = 2 IF (LIMIT .EQ. 1) IER = 1 IF (IER .NE. 0) GO TO 999 C C INITIALIZATION C -------------- C RLIST2(1) = RESULT ERRMAX = ABSERR MAXERR = 1 AREA = RESULT ERRSUM = ABSERR ABSERR = OFLOW CORREC = 0.D0 NRMAX = 1 NRES = 0 NUMRL2 = 2 KTMIN = 0 EXTRAP = .FALSE. NOEXT = .FALSE. IROFF1 = 0 IROFF2 = 0 IROFF3 = 0 KSGN = -1 IF (DRES .GE. (1.D0 - 50.D0*EPMACH)*DEFABS) KSGN = 1 T = 1.D0 + 100.D0*EPMACH C C MAIN DO-LOOP C ------------ C DO 90 LAST = 2,LIMIT C C BISECT THE SUBINTERVAL WITH THE NRMAX-TH LARGEST C ERROR ESTIMATE. C A1 = ALIST(MAXERR) B1 = 0.5D0*(ALIST(MAXERR) + BLIST(MAXERR)) A2 = B1 B2 = BLIST(MAXERR) ERLAST = ERRMAX CALL DQK21 (F, A1, B1, AREA1, ERROR1, RESABS, DEFAB1, * EPMACH, UFLOW, IER) IF (IER .NE. 0) GO TO 100 CALL DQK21 (F, A2, B2, AREA2, ERROR2, RESABS, DEFAB2, * EPMACH, UFLOW, IER) NEVAL = NEVAL + 42 C C IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL C AND ERROR AND TEST FOR ACCURACY. C AREA12 = AREA1 + AREA2 ERRO12 = ERROR1 + ERROR2 ERRSUM = ERRSUM + ERRO12 - ERRMAX AREA = AREA + AREA12 - RLIST(MAXERR) IF (DEFAB1 .EQ. ERROR1 .OR. DEFAB2 .EQ. ERROR2) GO TO 15 IF (DABS(RLIST(MAXERR) - AREA12) .GT. 0.1D-04*DABS(AREA12) * .OR. ERRO12 .LT. 0.99D0*ERRMAX) GO TO 10 IF (EXTRAP) IROFF2 = IROFF2 + 1 IF (.NOT.EXTRAP) IROFF1 = IROFF1 + 1 10 IF (LAST .GT. 10 .AND. ERRO12 .GT. ERRMAX) IROFF3 = IROFF3 + 1 15 RLIST(MAXERR) = AREA1 RLIST(LAST) = AREA2 ERRBND = DMAX1(EPSABS,RERR*DABS(AREA)) C C TEST FOR ROUNDOFF ERROR AND EVENTUALLY C SET ERROR FLAG. C IF (IROFF1 + IROFF2 .GE. 10 .OR. IROFF3 .GE. 20) IER = 2 IF (IROFF2 .GE. 5) IERRO = 3 C C SET ERROR FLAG IN THE CASE THAT THE NUMBER OF C SUBINTERVALS EQUALS LIMIT. C IF (LAST .EQ. LIMIT) IER = 1 C C SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR C AT A POINT OF THE INTEGRATION RANGE. C IF (DMAX1(DABS(A1),DABS(B2)) .LE. * T*(DABS(A2) + 0.1D+04*UFLOW)) IER = 4 C C APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. C IF (ERROR2 .GT. ERROR1) GO TO 20 ALIST(LAST) = A2 BLIST(MAXERR) = B1 BLIST(LAST) = B2 ELIST(MAXERR) = ERROR1 ELIST(LAST) = ERROR2 GO TO 30 20 ALIST(MAXERR) = A2 ALIST(LAST) = A1 BLIST(LAST) = B1 RLIST(MAXERR) = AREA2 RLIST(LAST) = AREA1 ELIST(MAXERR) = ERROR2 ELIST(LAST) = ERROR1 C C CALL SUBROUTINE DQPSRT TO MAINTAIN THE DESCENDING ORDERING C IN THE LIST OF ERROR ESTIMATES AND SELECT THE C SUBINTERVAL WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE C BISECTED NEXT). C 30 CALL DQPSRT (LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX) C ***JUMP OUT OF DO-LOOP IF (ERRSUM .LE. ERRBND) GO TO 115 C ***JUMP OUT OF DO-LOOP IF (IER .NE. 0) GO TO 100 IF (LAST .EQ. 2) GO TO 80 IF (NOEXT) GO TO 90 ERLARG = ERLARG - ERLAST IF (DABS(B1 - A1) .GT. SMALL) ERLARG = ERLARG + ERRO12 IF (EXTRAP) GO TO 40 C C TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE C SMALLEST INTERVAL. C IF (DABS(BLIST(MAXERR) - ALIST(MAXERR)) .GT. SMALL) GO TO 90 EXTRAP = .TRUE. NRMAX = 2 40 IF (IERRO .EQ. 3 .OR. ERLARG .LE. ERTEST) GO TO 60 C C THE SMALLEST INTERVAL HAS THE LARGEST ERROR. C BEFORE BISECTING DECREASE THE SUM OF THE ERRORS C OVER THE LARGER INTERVALS (ERLARG) AND PERFORM C EXTRAPOLATION. C ID = NRMAX JUPBND = LAST IF (LAST .GT. (2 + LIMIT/2)) JUPBND = LIMIT + 3 - LAST DO 50 K = ID,JUPBND MAXERR = IORD(NRMAX) ERRMAX = ELIST(MAXERR) C ***JUMP OUT OF DO-LOOP IF (DABS(BLIST(MAXERR) - ALIST(MAXERR)) .GT. SMALL) GO TO 90 NRMAX = NRMAX + 1 50 CONTINUE C C PERFORM EXTRAPOLATION. C 60 NUMRL2 = NUMRL2 + 1 RLIST2(NUMRL2) = AREA CALL DQELG (NUMRL2, RLIST2, RESEPS, ABSEPS, RES3LA, NRES, * EPMACH, OFLOW) KTMIN = KTMIN + 1 IF (KTMIN .GT. 5 .AND. ABSERR .LT. 0.1D-02*ERRSUM) IER = 5 IF (ABSEPS .GE. ABSERR) GO TO 70 KTMIN = 0 ABSERR = ABSEPS RESULT = RESEPS CORREC = ERLARG ERTEST = DMAX1(EPSABS,RERR*DABS(RESEPS)) C ***JUMP OUT OF DO-LOOP IF (ABSERR .LE. ERTEST) GO TO 100 C C PREPARE BISECTION OF THE SMALLEST INTERVAL. C 70 IF (NUMRL2 .EQ. 1) NOEXT = .TRUE. IF (IER .EQ. 5) GO TO 100 MAXERR = IORD(1) ERRMAX = ELIST(MAXERR) NRMAX = 1 EXTRAP = .FALSE. SMALL = SMALL*0.5D0 ERLARG = ERRSUM GO TO 90 80 SMALL = DABS(B - A)*0.375D0 ERLARG = ERRSUM ERTEST = ERRBND RLIST2(2) = AREA 90 CONTINUE C C SET FINAL RESULT AND ERROR ESTIMATE. C ------------------------------------ C 100 IF (ABSERR .EQ. OFLOW) GO TO 115 IF (IER + IERRO .EQ. 0) GO TO 110 IF (IERRO .EQ. 3) ABSERR = ABSERR + CORREC IF (IER .EQ. 0) IER = 3 IF (RESULT .NE. 0.D0 .AND. AREA .NE. 0.D0) GO TO 105 IF (ABSERR .GT. ERRSUM) GO TO 115 IF (AREA .EQ. 0.D0) GO TO 130 GO TO 110 105 IF (ABSERR/DABS(RESULT) .GT. ERRSUM/DABS(AREA)) GO TO 115 C C TEST ON DIVERGENCE. C 110 IF (KSGN .EQ. -1 .AND. DMAX1(DABS(RESULT),DABS(AREA)) .LE. * DEFABS*0.1D-01) GO TO 130 IF (0.1D-01 .GT. (RESULT/AREA) .OR. (RESULT/AREA) .GT. 0.1D+03 * .OR. ERRSUM .GT. DABS(AREA)) IER = 6 GO TO 130 C C COMPUTE GLOBAL INTEGRAL SUM. C 115 RESULT = 0.0 DO 120 K = 1,LAST RESULT = RESULT + RLIST(K) 120 CONTINUE ABSERR = ERRSUM 130 IF (IER .GT. 2) IER = IER - 1 999 RETURN END SUBROUTINE DQK21 (F, A, B, RESULT, ABSERR, RESABS, RESASC, * EPMACH, UFLOW, ISIG) C----------------------------------------------------------------------- C C 1. PURPOSE C TO COMPUTE I = INTEGRAL OF F OVER (A,B), WITH ERROR C ESTIMATE C J = INTEGRAL OF DABS(F) OVER (A,B) C C 2. PARAMETERS C ON ENTRY C F - DOUBLE PRECISION C FUNCTION SUBPROGRAM DEFINING THE INTEGRAND C FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS C TO BE DECLARED E X T E R N A L IN THE C CALLING PROGRAM. C C A - DOUBLE PRECISION C LOWER LIMIT OF INTEGRATION C C B - DOUBLE PRECISION C UPPER LIMIT OF INTEGRATION C C EPMACH - DOUBLE PRECISION C THE RELATIVE PRECISION OF THE FLOATING C ARITHMETIC BEING USED. C C UFLOW - DOUBLE PRECISION C THE SMALLEST POSITIVE MAGNITUDE. C C ON RETURN C RESULT - DOUBLE PRECISION C APPROXIMATION TO THE INTEGRAL I C RESULT IS COMPUTED BY APPLYING THE 21-POINT C KRONROD RULE (RESK) OBTAINED BY OPTIMAL C ADDITION OF ABSCISSAE TO THE 10-POINT GAUSS C RULE (RESG). C C ABSERR - DOUBLE PRECISION C ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR, C WHICH SHOULD NOT EXCEED ABS(I-RESULT) C C RESABS - DOUBLE PRECISION C APPROXIMATION TO THE INTEGRAL J C C RESASC - DOUBLE PRECISION C APPROXIMATION TO THE INTEGRAL OF ABS(F-I/(B-A)) C OVER (A,B) C C ISIG - INTEGER C ISIG=0 THE INTEGRAL WAS APPROXIMATED. C ISIG=5 THE INTERVAL (A,B) IS TOO SHORT. C THE INTEGRAL CANNOT BE COMPUTED. C C 3. SUBROUTINES OR FUNCTIONS NEEDED C - F (USER-PROVIDED FUNCTION) C C----------------------------------------------------------------------- DOUBLE PRECISION A,ABSC,ABSERR,B,CENTR,DHLGTH,EPMACH,F,FC, * FSUM,FVAL1,FVAL2,FV1,FV2,HLGTH,RESABS,RESG,RESK,RESKH, * RESULT,TOL,UFLOW,WG,WGK,XGK,RESASC INTEGER ISIG,J,JTW,JTWM1 C DIMENSION FV1(10), FV2(10), WG(5), WGK(11), XGK(11) EXTERNAL F C C THE ABSCISSAE AND WEIGHTS ARE GIVEN FOR THE INTERVAL (-1,1). C BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND THEIR C CORRESPONDING WEIGHTS ARE GIVEN. C C XGK - ABSCISSAE OF THE 21-POINT KRONROD RULE C XGK(2), XGK(4), ... ABSCISSAE OF THE 10-POINT C GAUSS RULE C XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY C ADDED TO THE 10-POINT GAUSS RULE C C WGK - WEIGHTS OF THE 21-POINT KRONROD RULE C C WG - WEIGHTS OF THE 10-POINT GAUSS RULE C DATA XGK(1),XGK(2),XGK(3),XGK(4),XGK(5),XGK(6),XGK(7), * XGK(8),XGK(9),XGK(10),XGK(11)/ * 0.995657163025808080735527280689D+00, * 0.973906528517171720077964012084D+00, * 0.930157491355708226001207180060D+00, * 0.865063366688984510732096688423D+00, * 0.780817726586416897063717578345D+00, * 0.679409568299024406234327365115D+00, * 0.562757134668604683339000099273D+00, * 0.433395394129247190799265943166D+00, * 0.294392862701460198131126603104D+00, * 0.148874338981631210884826001130D+00, * 0.000000000000000000000000000000D+00/ C DATA WGK(1),WGK(2),WGK(3),WGK(4),WGK(5),WGK(6),WGK(7), * WGK(8),WGK(9),WGK(10),WGK(11)/ * 0.116946388673718742780643960622D-01, * 0.325581623079647274788189724594D-01, * 0.547558965743519960313813002446D-01, * 0.750396748109199527670431409162D-01, * 0.931254545836976055350654650834D-01, * 0.109387158802297641899210590326D+00, * 0.123491976262065851077958109831D+00, * 0.134709217311473325928054001772D+00, * 0.142775938577060080797094273139D+00, * 0.147739104901338491374841515972D+00, * 0.149445554002916905664936468390D+00/ C DATA WG(1),WG(2),WG(3),WG(4),WG(5)/ * 0.666713443086881375935688098933D-01, * 0.149451349150580593145776339658D+00, * 0.219086362515982043995534934228D+00, * 0.269266719309996355091226921569D+00, * 0.295524224714752870173892994651D+00/ C C C LIST OF MAJOR VARIABLES C ----------------------- C C CENTR - MID POINT OF THE INTERVAL C HLGTH - HALF-LENGTH OF THE INTERVAL C ABSC - ABSCISSA C FVAL* - FUNCTION VALUE C RESG - RESULT OF THE 10-POINT GAUSS FORMULA C RESK - RESULT OF THE 21-POINT KRONROD FORMULA C RESKH - APPROXIMATION TO THE MEAN VALUE OF F OVER (A,B), C I.E. TO I/(B-A) C C CENTR = 0.5D0*(A + B) HLGTH = 0.5D0*(B - A) DHLGTH = DABS(HLGTH) C C CHECK IF THE INTERVAL (A,B) IS TOO SHORT C ISIG = 5 ABSC = DABS(CENTR) + DHLGTH*0.14D0 IF (ABSC .EQ. DABS(CENTR)) RETURN C C COMPUTE THE 21-POINT KRONROD APPROXIMATION TO C THE INTEGRAL, AND ESTIMATE THE ABSOLUTE ERROR. C ISIG = 0 RESG = 0.D0 FC = F(CENTR) RESK = WGK(11)*FC RESABS = DABS(RESK) DO 10 J = 1,5 JTW = 2*J ABSC = HLGTH*XGK(JTW) FVAL1 = F(CENTR - ABSC) FVAL2 = F(CENTR + ABSC) FV1(JTW) = FVAL1 FV2(JTW) = FVAL2 FSUM = FVAL1 + FVAL2 RESG = RESG + WG(J)*FSUM RESK = RESK + WGK(JTW)*FSUM RESABS = RESABS + WGK(JTW)*(DABS(FVAL1) + DABS(FVAL2)) 10 CONTINUE DO 15 J = 1,5 JTWM1 = 2*J - 1 ABSC = HLGTH*XGK(JTWM1) FVAL1 = F(CENTR - ABSC) FVAL2 = F(CENTR + ABSC) FV1(JTWM1) = FVAL1 FV2(JTWM1) = FVAL2 FSUM = FVAL1 + FVAL2 RESK = RESK + WGK(JTWM1)*FSUM RESABS = RESABS + WGK(JTWM1)*(DABS(FVAL1) + DABS(FVAL2)) 15 CONTINUE RESKH = RESK*0.5D0 RESASC = WGK(11)*DABS(FC - RESKH) DO 20 J = 1,10 RESASC = RESASC + WGK(J)*(DABS(FV1(J)-RESKH) * + DABS(FV2(J)-RESKH)) 20 CONTINUE RESULT = RESK*HLGTH RESABS = RESABS*DHLGTH RESASC = RESASC*DHLGTH ABSERR = DABS((RESK - RESG)*HLGTH) IF (RESASC .NE. 0.D0 .AND. ABSERR .NE. 0.D0) * ABSERR = RESASC*DMIN1(1.D0, * (0.2D+03*ABSERR/RESASC)**1.5D0) TOL = EPMACH*0.5D+02 IF (RESABS .GT. UFLOW/TOL) ABSERR = DMAX1(ABSERR,TOL*RESABS) RETURN END SUBROUTINE DQAGI (F, BOUND, INF, EPSABS, EPSREL, RESULT, ABSERR, * NEVAL, IER, LIMIT, LENW, LAST, IWORK, WORK) C----------------------------------------------------------------------- C C DOUBLE PRECISION INTEGRATION OVER INFINITE INTERVALS C C----------------------------------------------------------------------- C C PURPOSE C THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO A GIVEN C INTEGRAL I = INTEGRAL OF F OVER (BOUND,+INFINITY) C OR I = INTEGRAL OF F OVER (-INFINITY,BOUND) C OR I = INTEGRAL OF F OVER (-INFINITY,+INFINITY), C HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY C ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). C C PARAMETERS C ON ENTRY C F - DOUBLE PRECISION C FUNCTION SUBPROGRAM DEFINING THE INTEGRAND C FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE C DECLARED E X T E R N A L IN THE DRIVER PROGRAM. C C BOUND - DOUBLE PRECISION C FINITE BOUND OF INTEGRATION RANGE C (HAS NO MEANING IF INTERVAL IS DOUBLY-INFINITE) C C INF - INTEGER C INDICATING THE KIND OF INTEGRATION RANGE C INVOLVED C INF = 1 CORRESPONDS TO (BOUND,+INFINITY), C INF = -1 TO (-INFINITY,BOUND), C INF = 2 TO (-INFINITY,+INFINITY). C C EPSABS - DOUBLE PRECISION C ABSOLUTE ACCURACY REQUESTED C C EPSREL - DOUBLE PRECISION C RELATIVE ACCURACY REQUESTED C C ON RETURN C RESULT - DOUBLE PRECISION C APPROXIMATION TO THE INTEGRAL C C ABSERR - DOUBLE PRECISION C ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR, C WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT) C C NEVAL - INTEGER C NUMBER OF INTEGRAND EVALUATIONS C C IER - INTEGER C IER = 0 NORMAL AND RELIABLE TERMINATION OF THE C ROUTINE. IT IS ASSUMED THAT THE REQUESTED C ACCURACY HAS BEEN ACHIEVED. C - IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE. THE C ESTIMATES FOR RESULT AND ERROR ARE LESS C RELIABLE. IT IS ASSUMED THAT THE REQUESTED C ACCURACY HAS NOT BEEN ACHIEVED. C C IER = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED C HAS BEEN ACHIEVED. ONE CAN ALLOW MORE C SUBDIVISIONS BY INCREASING THE VALUE C OF LIMIT (AND TAKING THE ACCORDING C DIMENSION ADJUSTMENTS INTO ACCOUNT). C HOWEVER, IF THIS YIELDS NO IMPROVEMENT C IT IS ADVISED TO ANALYZE THE INTEGRAND C IN ORDER TO DETERMINE THE INTEGRATION C DIFFICULTIES. IF THE POSITION OF A LOCAL C DIFFICULTY CAN BE DETERMINED (E.G. C SINGULARITY, DISCONTINUITY WITHIN THE C INTERVAL) ONE WILL PROBABLY GAIN FROM C SPLITTING UP THE INTERVAL AT THIS POINT C AND CALLING THE INTEGRATOR ON THE C SUBRANGES. IF POSSIBLE, AN APPROPRIATE C SPECIAL-PURPOSE INTEGRATOR SHOULD BE USED, C WHICH IS DESIGNED FOR HANDLING THE TYPE C OF DIFFICULTY INVOLVED. C = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS C DETECTED, WHICH PREVENTS THE REQUESTED C TOLERANCE FROM BEING ACHIEVED. C THE ERROR MAY BE UNDER-ESTIMATED. C = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR OCCURS C AT SOME POINTS OF THE INTEGRATION C INTERVAL. C = 4 THE ALGORITHM DOES NOT CONVERGE. C ROUNDOFF ERROR IS DETECTED IN THE C EXTRAPOLATION TABLE. C IT IS ASSUMED THAT THE REQUESTED TOLERANCE C CANNOT BE ACHIEVED, AND THAT THE RETURNED C RESULT IS THE BEST WHICH CAN BE OBTAINED. C = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR C SLOWLY CONVERGENT. IT MUST BE NOTED THAT C DIVERGENCE CAN OCCUR WITH ANY OTHER VALUE C OF IER. C = 6 THE INPUT IS INVALID BECAUSE EPSABS C OR EPSREL IS NEGATIVE, LIMIT .LT. 1, C OR LENW .LT. 4 * LIMIT. C RESULT, ABSERR, NEVAL, LAST ARE C SET TO ZERO. C C DIMENSIONING PARAMETERS C LIMIT - INTEGER C DIMENSIONING PARAMETER FOR IWORK C LIMIT DETERMINES THE MAXIMUM NUMBER C OF SUBINTERVALS IN THE PARTITION OF THE GIVEN C INTEGRATION INTERVAL (A,B), LIMIT.GE.1. C IF LIMIT.LT.1, THE ROUTINE WILL END WITH C IER = 6. C C LENW - INTEGER C DIMENSIONING PARAMETER FOR WORK C LENW MUST BE AT LEAST LIMIT*4. C IF LENW.LT.LIMIT*4, THE ROUTINE WILL END C WITH IER = 6. C C LAST - INTEGER C ON RETURN, LAST EQUALS THE NUMBER OF C SUBINTERVALS PRODUCED IN THE SUBDIVISION C PROCESS, WHICH DETERMINES THE NUMBER OF SIGNIFICANT C ELEMENTS ACTUALLY IN THE WORK ARRAYS. C C WORK ARRAYS C IWORK - INTEGER C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST C K ELEMENTS OF WHICH CONTAIN POINTERS C TO THE ERROR ESTIMATES OVER THE SUBINTERVALS, C SUCH THAT WORK(LIMIT*3+IWORK(1)),... , C WORK(LIMIT*3+IWORK(K)) FORM A DECREASING C SEQUENCE, WITH K = LAST IF LAST.LE.(LIMIT/2+2), AND C K = LIMIT+1-LAST OTHERWISE C C WORK - DOUBLE PRECISION C VECTOR OF DIMENSION AT LEAST LENW C ON RETURN C WORK(1), ..., WORK(LAST) CONTAIN THE LEFT C END POINTS OF THE SUBINTERVALS IN THE C PARTITION OF (A,B), C WORK(LIMIT+1), ..., WORK(LIMIT+LAST) CONTAIN C THE RIGHT END POINTS, C WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) C CONTAIN THE INTEGRAL APPROXIMATIONS OVER C THE SUBINTERVALS, C WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST) C CONTAIN THE ERROR ESTIMATES. C C SUBROUTINES OR FUNCTIONS NEEDED C - DQAGIE C - DQK15I C - DQPSRT C - DQELG C - F (USER PROVIDED FUNCTION) C - DPMPAR C C----------------------------------------------------------------------- DOUBLE PRECISION ABSERR,BOUND,EPSABS,EPSREL,F,RESULT,WORK INTEGER IER,IWORK,LENW,LIMIT,L1,L2,L3,NEVAL C DIMENSION IWORK(LIMIT),WORK(LENW) C EXTERNAL F C C CHECK VALIDITY OF LIMIT AND LENW. C IER = 6 NEVAL = 0 LAST = 0 RESULT = 0.D0 ABSERR = 0.D0 IF (LIMIT .LT. 1 .OR. LENW .LT. LIMIT*4) RETURN C C PREPARE CALL FOR DQAGIE C L1 = LIMIT + 1 L2 = LIMIT + L1 L3 = LIMIT + L2 C CALL DQAGIE (F,BOUND,INF,EPSABS,EPSREL,LIMIT,RESULT,ABSERR, * NEVAL,IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST) RETURN END SUBROUTINE DQAGIE (F,BOUND,INF,EPSABS,EPSREL,LIMIT,RESULT,ABSERR, * NEVAL,IER,ALIST,BLIST,RLIST,ELIST,IORD,LAST) C----------------------------------------------------------------------- C C INTEGRATION OVER INFINITE INTERVALS C C----------------------------------------------------------------------- C C PURPOSE C THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO A GIVEN C INTEGRAL I = INTEGRAL OF F OVER (BOUND,+INFINITY) C OR I = INTEGRAL OF F OVER (-INFINITY,BOUND) C OR I = INTEGRAL OF F OVER (-INFINITY,+INFINITY), C HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY C ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)). C C PARAMETERS C ON ENTRY C F - DOUBLE PRECISION C FUNCTION SUBPROGRAM DEFINING THE INTEGRAND C FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE C DECLARED E X T E R N A L IN THE DRIVER PROGRAM. C C BOUND - DOUBLE PRECISION C FINITE BOUND OF INTEGRATION RANGE C (HAS NO MEANING IF INTERVAL IS DOUBLY-INFINITE) C C INF - INTEGER C INDICATING THE KIND OF INTEGRATION RANGE C INVOLVED C INF = 1 CORRESPONDS TO (BOUND,+INFINITY), C INF = -1 TO (-INFINITY,BOUND), C INF = 2 TO (-INFINITY,+INFINITY). C C EPSABS - DOUBLE PRECISION C ABSOLUTE ACCURACY REQUESTED C C EPSREL - DOUBLE PRECISION C RELATIVE ACCURACY REQUESTED C C LIMIT - INTEGER C GIVES AN UPPER BOUND ON THE NUMBER OF C SUBINTERVALS IN THE PARTITION OF (A,B), C LIMIT.GE.1 C C ON RETURN C RESULT - DOUBLE PRECISION C APPROXIMATION TO THE INTEGRAL C C ABSERR - DOUBLE PRECISION C ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR, C WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT) C C NEVAL - INTEGER C NUMBER OF INTEGRAND EVALUATIONS C C IER - INTEGER C IER = 0 NORMAL AND RELIABLE TERMINATION OF THE C ROUTINE. IT IS ASSUMED THAT THE REQUESTED C ACCURACY HAS BEEN ACHIEVED. C - IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE. THE C ESTIMATES FOR RESULT AND ERROR ARE LESS C RELIABLE. IT IS ASSUMED THAT THE REQUESTED C ACCURACY HAS NOT BEEN ACHIEVED. C C IER = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED C HAS BEEN ACHIEVED. ONE CAN ALLOW MORE C SUBDIVISIONS BY INCREASING THE VALUE C OF LIMIT (AND TAKING THE ACCORDING C DIMENSION ADJUSTMENTS INTO ACCOUNT). C HOWEVER, IF THIS YIELDS NO IMPROVEMENT C IT IS ADVISED TO ANALYZE THE INTEGRAND C IN ORDER TO DETERMINE THE INTEGRATION C DIFFICULTIES. IF THE POSITION OF A LOCAL C DIFFICULTY CAN BE DETERMINED (E.G. C SINGULARITY, DISCONTINUITY WITHIN THE C INTERVAL) ONE WILL PROBABLY GAIN FROM C SPLITTING UP THE INTERVAL AT THIS POINT C AND CALLING THE INTEGRATOR ON THE C SUBRANGES. IF POSSIBLE, AN APPROPRIATE C SPECIAL-PURPOSE INTEGRATOR SHOULD BE USED, C WHICH IS DESIGNED FOR HANDLING THE TYPE C OF DIFFICULTY INVOLVED. C = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS C DETECTED, WHICH PREVENTS THE REQUESTED C TOLERANCE FROM BEING ACHIEVED. C THE ERROR MAY BE UNDER-ESTIMATED. C = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR OCCURS C AT SOME POINTS OF THE INTEGRATION C INTERVAL. C = 4 THE ALGORITHM DOES NOT CONVERGE. C ROUNDOFF ERROR IS DETECTED IN THE C EXTRAPOLATION TABLE. C IT IS ASSUMED THAT THE REQUESTED TOLERANCE C CANNOT BE ACHIEVED, AND THAT THE RETURNED C RESULT IS THE BEST WHICH CAN BE OBTAINED. C = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR C SLOWLY CONVERGENT. IT MUST BE NOTED THAT C DIVERGENCE CAN OCCUR WITH ANY OTHER VALUE C OF IER. C = 6 THE INPUT IS INVALID BECAUSE EPSABS C OR EPSREL IS NEGATIVE. C RESULT, ABSERR, NEVAL, LAST, RLIST(1), C ELIST(1) AND IORD(1) ARE SET TO ZERO. C ALIST(1) AND BLIST(1) ARE SET TO 0 C AND 1 RESPECTIVELY. C C ALIST - DOUBLE PRECISION C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST C LAST ELEMENTS OF WHICH ARE THE LEFT C END POINTS OF THE SUBINTERVALS IN THE PARTITION C OF THE TRANSFORMED INTEGRATION RANGE (0,1). C C BLIST - DOUBLE PRECISION C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST C LAST ELEMENTS OF WHICH ARE THE RIGHT C END POINTS OF THE SUBINTERVALS IN THE PARTITION C OF THE TRANSFORMED INTEGRATION RANGE (0,1). C C RLIST - DOUBLE PRECISION C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST C LAST ELEMENTS OF WHICH ARE THE INTEGRAL C APPROXIMATIONS ON THE SUBINTERVALS C C ELIST - DOUBLE PRECISION C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST C LAST ELEMENTS OF WHICH ARE THE MODULI C OF THE ABSOLUTE ERROR ESTIMATES ON THE C SUBINTERVALS C C IORD - INTEGER C VECTOR OF DIMENSION LIMIT, THE FIRST K C ELEMENTS OF WHICH ARE POINTERS TO THE C ERROR ESTIMATES OVER THE SUBINTERVALS, C SUCH THAT ELIST(IORD(1)), ..., ELIST(IORD(K)) C FORM A DECREASING SEQUENCE, WITH K = LAST C IF LAST.LE.(LIMIT/2+2), AND K = LIMIT+1-LAST C OTHERWISE C C LAST - INTEGER C NUMBER OF SUBINTERVALS ACTUALLY PRODUCED C IN THE SUBDIVISION PROCESS C C SUBROUTINES OR FUNCTIONS NEEDED C - DQK15I C - DQPSRT C - DQELG C - F (USER-PROVIDED FUNCTION) C - DPMPAR C C----------------------------------------------------------------------- DOUBLE PRECISION ABSEPS,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1, * A2,BLIST,BOUN,BOUND,B1,B2,CORREC,DEFABS,DEFAB1,DEFAB2,DRES, * DPMPAR,ELIST,EPMACH,EPSABS,EPSREL,ERLARG,ERLAST,ERRBND, * ERRMAX,ERROR1,ERROR2,ERRO12,ERRSUM,ERTEST,F,OFLOW,RERR,RESABS, * RESEPS,RESULT,RES3LA,RLIST,RLIST2,SMALL,T,UFLOW INTEGER ID,IER,IERRO,INF,IORD,IROFF1,IROFF2,IROFF3,JUPBND,K,KSGN, * KTMIN,LAST,LIMIT,MAXERR,NEVAL,NRES,NRMAX,NUMRL2 LOGICAL EXTRAP,NOEXT C DIMENSION ALIST(LIMIT),BLIST(LIMIT),ELIST(LIMIT),IORD(LIMIT), * RES3LA(3),RLIST(LIMIT),RLIST2(52) C EXTERNAL F C C THE DIMENSION OF RLIST2 IS DETERMINED BY THE VALUE OF C LIMEXP IN SUBROUTINE DQELG. C C C LIST OF MAJOR VARIABLES C ----------------------- C C ALIST - LIST OF LEFT END POINTS OF ALL SUBINTERVALS C CONSIDERED UP TO NOW C BLIST - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS C CONSIDERED UP TO NOW C RLIST(I) - APPROXIMATION TO THE INTEGRAL OVER C (ALIST(I),BLIST(I)) C RLIST2 - ARRAY OF DIMENSION AT LEAST (LIMEXP+2), C CONTAINING THE PART OF THE EPSILON TABLE C WICH IS STILL NEEDED FOR FURTHER COMPUTATIONS C ELIST(I) - ERROR ESTIMATE APPLYING TO RLIST(I) C MAXERR - POINTER TO THE INTERVAL WITH LARGEST ERROR C ESTIMATE C ERRMAX - ELIST(MAXERR) C ERLAST - ERROR ON THE INTERVAL CURRENTLY SUBDIVIDED C (BEFORE THAT SUBDIVISION HAS TAKEN PLACE) C AREA - SUM OF THE INTEGRALS OVER THE SUBINTERVALS C ERRSUM - SUM OF THE ERRORS OVER THE SUBINTERVALS C ERRBND - REQUESTED ACCURACY MAX(EPSABS,EPSREL* C ABS(RESULT)) C *****1 - VARIABLE FOR THE LEFT SUBINTERVAL C *****2 - VARIABLE FOR THE RIGHT SUBINTERVAL C LAST - INDEX FOR SUBDIVISION C NRES - NUMBER OF CALLS TO THE EXTRAPOLATION ROUTINE C NUMRL2 - NUMBER OF ELEMENTS CURRENTLY IN RLIST2. IF AN C APPROPRIATE APPROXIMATION TO THE COMPOUNDED C INTEGRAL HAS BEEN OBTAINED, IT IS PUT IN C RLIST2(NUMRL2) AFTER NUMRL2 HAS BEEN INCREASED C BY ONE. C SMALL - LENGTH OF THE SMALLEST INTERVAL CONSIDERED UP C TO NOW, MULTIPLIED BY 1.5 C ERLARG - SUM OF THE ERRORS OVER THE INTERVALS LARGER C THAN THE SMALLEST INTERVAL CONSIDERED UP TO NOW C EXTRAP - LOGICAL VARIABLE DENOTING THAT THE ROUTINE C IS ATTEMPTING TO PERFORM EXTRAPOLATION. I.E. C BEFORE SUBDIVIDING THE SMALLEST INTERVAL WE C TRY TO DECREASE THE VALUE OF ERLARG. C NOEXT - LOGICAL VARIABLE DENOTING THAT EXTRAPOLATION C IS NO LONGER ALLOWED (TRUE-VALUE) C C MACHINE DEPENDENT CONSTANTS C --------------------------- C C EPMACH IS THE LARGEST RELATIVE SPACING. C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. C OFLOW IS THE LARGEST POSITIVE MAGNITUDE. C EPMACH = DPMPAR(1) UFLOW = DPMPAR(2) OFLOW = DPMPAR(3) C C CHECK EPSABS AND EPSREL C ----------------------- C NEVAL = 0 LAST = 0 RESULT = 0.D0 ABSERR = 0.D0 ALIST(1) = 0.D0 BLIST(1) = 1.D0 RLIST(1) = 0.D0 ELIST(1) = 0.D0 IORD(1) = 0 IER = 6 IF (EPSABS .LT. 0.D0 .OR. EPSREL .LT. 0.D0) GO TO 999 IER = 0 RERR = DMAX1(EPSREL, 50.D0*EPMACH, 0.5D-28) C C FIRST APPROXIMATION TO THE INTEGRAL C ----------------------------------- C C DETERMINE THE INTERVAL TO BE MAPPED ONTO (0,1). C IF INF = 2 THE INTEGRAL IS COMPUTED AS I = I1+I2, WHERE C I1 = INTEGRAL OF F OVER (-INFINITY,0), C I2 = INTEGRAL OF F OVER (0,+INFINITY). C BOUN = BOUND IF (INF .EQ. 2) BOUN = 0.D0 CALL DQK15I (F, BOUN, INF, 0.D0, 1.D0, RESULT, ABSERR, * DEFABS, RESABS, EPMACH, UFLOW) C C TEST ON ACCURACY C LAST = 1 RLIST(1) = RESULT ELIST(1) = ABSERR IORD(1) = 1 DRES = DABS(RESULT) ERRBND = DMAX1(EPSABS,RERR*DRES) IF (ABSERR .LE. 100.D0*EPMACH*DEFABS .AND. ABSERR .GT. ERRBND) * IER = 2 IF (LIMIT .EQ. 1) IER = 1 IF (IER .NE. 0 .OR. (ABSERR .LE. ERRBND .AND. ABSERR .NE. RESABS) * .OR. ABSERR .EQ. 0.D0) GO TO 130 C C INITIALIZATION C -------------- C RLIST2(1) = RESULT ERRMAX = ABSERR MAXERR = 1 AREA = RESULT ERRSUM = ABSERR ABSERR = OFLOW CORREC = 0.D0 NRMAX = 1 NRES = 0 KTMIN = 0 NUMRL2 = 2 EXTRAP = .FALSE. NOEXT = .FALSE. IERRO = 0 IROFF1 = 0 IROFF2 = 0 IROFF3 = 0 KSGN = -1 IF (DRES .GE. (1.D0 - 50.D0*EPMACH)*DEFABS) KSGN = 1 T = 1.D0 + 100.D0*EPMACH C C MAIN DO-LOOP C ------------ C DO 90 LAST = 2,LIMIT C C BISECT THE SUBINTERVAL WITH NRMAX-TH LARGEST C ERROR ESTIMATE. C A1 = ALIST(MAXERR) B1 = 0.5D0*(ALIST(MAXERR) + BLIST(MAXERR)) A2 = B1 B2 = BLIST(MAXERR) ERLAST = ERRMAX CALL DQK15I (F, BOUN, INF, A1, B1, AREA1, ERROR1, * RESABS, DEFAB1, EPMACH, UFLOW) CALL DQK15I (F, BOUN, INF, A2, B2, AREA2, ERROR2, * RESABS, DEFAB2, EPMACH, UFLOW) C C IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL C AND ERROR AND TEST FOR ACCURACY. C AREA12 = AREA1 + AREA2 ERRO12 = ERROR1 + ERROR2 ERRSUM = ERRSUM + ERRO12 - ERRMAX AREA = AREA + AREA12 - RLIST(MAXERR) IF (DEFAB1 .EQ. ERROR1 .OR. DEFAB2 .EQ. ERROR2) GO TO 15 IF (DABS(RLIST(MAXERR) - AREA12) .GT. 0.1D-04*DABS(AREA12) * .OR. ERRO12 .LT. 0.99D0*ERRMAX) GO TO 10 IF (EXTRAP) IROFF2 = IROFF2 + 1 IF (.NOT.EXTRAP) IROFF1 = IROFF1 + 1 10 IF (LAST .GT. 10 .AND. ERRO12 .GT. ERRMAX) IROFF3 = IROFF3 + 1 15 RLIST(MAXERR) = AREA1 RLIST(LAST) = AREA2 ERRBND = DMAX1(EPSABS,RERR*DABS(AREA)) C C TEST FOR ROUNDOFF ERROR AND EVENTUALLY C SET ERROR FLAG. C IF (IROFF1 + IROFF2 .GE. 10 .OR. IROFF3 .GE. 20) IER = 2 IF (IROFF2 .GE. 5) IERRO = 3 C C SET ERROR FLAG IN THE CASE THAT THE NUMBER OF C SUBINTERVALS EQUALS LIMIT. C IF (LAST .EQ. LIMIT) IER = 1 C C SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR C AT SOME POINTS OF THE INTEGRATION RANGE. C IF (DMAX1(DABS(A1),DABS(B2)) .LE. * T*(DABS(A2) + 0.1D+04*UFLOW)) IER = 4 C C APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. C IF (ERROR2 .GT. ERROR1) GO TO 20 ALIST(LAST) = A2 BLIST(MAXERR) = B1 BLIST(LAST) = B2 ELIST(MAXERR) = ERROR1 ELIST(LAST) = ERROR2 GO TO 30 20 ALIST(MAXERR) = A2 ALIST(LAST) = A1 BLIST(LAST) = B1 RLIST(MAXERR) = AREA2 RLIST(LAST) = AREA1 ELIST(MAXERR) = ERROR2 ELIST(LAST) = ERROR1 C C CALL SUBROUTINE DQPSRT TO MAINTAIN THE DESCENDING ORDERING C IN THE LIST OF ERROR ESTIMATES AND SELECT THE C SUBINTERVAL WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE C BISECTED NEXT). C 30 CALL DQPSRT (LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX) IF (ERRSUM .LE. ERRBND) GO TO 115 IF (IER .NE. 0) GO TO 100 IF (LAST .EQ. 2) GO TO 80 IF (NOEXT) GO TO 90 ERLARG = ERLARG - ERLAST IF (DABS(B1 - A1) .GT. SMALL) ERLARG = ERLARG + ERRO12 IF (EXTRAP) GO TO 40 C C TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE C SMALLEST INTERVAL. C IF (DABS(BLIST(MAXERR) - ALIST(MAXERR)) .GT. SMALL) GO TO 90 EXTRAP = .TRUE. NRMAX = 2 40 IF (IERRO .EQ. 3 .OR. ERLARG .LE. ERTEST) GO TO 60 C C THE SMALLEST INTERVAL HAS THE LARGEST ERROR. C BEFORE BISECTING DECREASE THE SUM OF THE ERRORS C OVER THE LARGER INTERVALS (ERLARG) AND PERFORM C EXTRAPOLATION. C ID = NRMAX JUPBND = LAST IF (LAST .GT. (2 + LIMIT/2)) JUPBND = LIMIT + 3 - LAST DO 50 K = ID,JUPBND MAXERR = IORD(NRMAX) ERRMAX = ELIST(MAXERR) IF (DABS(BLIST(MAXERR) - ALIST(MAXERR)) .GT. SMALL) GO TO 90 NRMAX = NRMAX + 1 50 CONTINUE C C PERFORM EXTRAPOLATION. C 60 NUMRL2 = NUMRL2 + 1 RLIST2(NUMRL2) = AREA CALL DQELG (NUMRL2, RLIST2, RESEPS, ABSEPS, RES3LA, NRES, * EPMACH, OFLOW) KTMIN = KTMIN + 1 IF (KTMIN .GT. 5 .AND. ABSERR .LT. 0.1D-02*ERRSUM) IER = 5 IF (ABSEPS .GE. ABSERR) GO TO 70 KTMIN = 0 ABSERR = ABSEPS RESULT = RESEPS CORREC = ERLARG ERTEST = DMAX1(EPSABS,RERR*DABS(RESEPS)) IF (ABSERR .LE. ERTEST) GO TO 100 C C PREPARE BISECTION OF THE SMALLEST INTERVAL. C 70 IF (NUMRL2 .EQ. 1) NOEXT = .TRUE. IF (IER .EQ. 5) GO TO 100 MAXERR = IORD(1) ERRMAX = ELIST(MAXERR) NRMAX = 1 EXTRAP = .FALSE. SMALL = SMALL*0.5D0 ERLARG = ERRSUM GO TO 90 80 SMALL = 0.375D0 ERLARG = ERRSUM ERTEST = ERRBND RLIST2(2) = AREA 90 CONTINUE C C SET FINAL RESULT AND ERROR ESTIMATE. C ------------------------------------ C 100 IF (ABSERR .EQ. OFLOW) GO TO 115 IF (IER + IERRO .EQ. 0) GO TO 110 IF (IERRO .EQ. 3) ABSERR = ABSERR + CORREC IF (IER .EQ. 0) IER = 3 IF (RESULT .NE. 0.D0 .AND. AREA .NE. 0.D0) GO TO 105 IF (ABSERR .GT. ERRSUM) GO TO 115 IF (AREA .EQ. 0.D0) GO TO 130 GO TO 110 105 IF (ABSERR/DABS(RESULT) .GT. ERRSUM/DABS(AREA)) GO TO 115 C C TEST ON DIVERGENCE C 110 IF (KSGN .EQ. -1 .AND. DMAX1(DABS(RESULT),DABS(AREA)) .LE. * DEFABS*0.1D-01) GO TO 130 IF (0.1D-01 .GT. (RESULT/AREA) .OR. (RESULT/AREA) .GT. 0.1D+03 * .OR. ERRSUM .GT. DABS(AREA)) IER = 6 GO TO 130 C C COMPUTE GLOBAL INTEGRAL SUM. C 115 RESULT = 0.D0 DO 120 K = 1,LAST RESULT = RESULT + RLIST(K) 120 CONTINUE ABSERR = ERRSUM 130 NEVAL = 30*LAST - 15 IF (INF .EQ. 2) NEVAL = 2*NEVAL IF (IER .GT. 2) IER = IER - 1 999 RETURN END SUBROUTINE DQK15I (F, BOUN, INF, A, B, RESULT, ABSERR, RESABS, * RESASC, EPMACH, UFLOW) C----------------------------------------------------------------------- C C 1. PURPOSE C THE ORIGINAL (INFINITE) INTEGRATION RANGE IS MAPPED C ONTO THE INTERVAL (0,1) AND (A,B) IS A PART OF (0,1). C IT IS THE PURPOSE TO COMPUTE C I = INTEGRAL OF TRANSFORMED INTEGRAND OVER (A,B), C J = INTEGRAL OF ABS(TRANSFORMED INTEGRAND) OVER (A,B). C C 2. PARAMETERS C ON ENTRY C F - DOUBLE PRECISION C FUNCTION SUBPROGRAM DEFINING THE INTEGRAND C FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS C TO BE DECLARED E X T E R N A L IN THE C CALLING PROGRAM. C C BOUN - DOUBLE PRECISION C FINITE BOUND OF ORIGINAL INTEGRATION C RANGE (SET TO ZERO IF INF = +2) C C INF - INTEGER C IF INF = -1, THE ORIGINAL INTERVAL IS C (-INFINITY,BOUND), C IF INF = +1, THE ORIGINAL INTERVAL IS C (BOUND,+INFINITY), C IF INF = +2, THE ORIGINAL INTERVAL IS C (-INFINITY,+INFINITY) AND C THE INTEGRAL IS COMPUTED AS THE SUM OF TWO C INTEGRALS, ONE OVER (-INFINITY,0) C AND ONE OVER (0,+INFINITY). C C A - DOUBLE PRECISION C LOWER LIMIT FOR INTEGRATION OVER SUBRANGE C OF (0,1) C C B - DOUBLE PRECISION C UPPER LIMIT FOR INTEGRATION OVER SUBRANGE C OF (0,1) C C EPMACH - DOUBLE PRECISION C THE RELATIVE PRECISION OF THE FLOATING C ARITHMETIC BEING USED. C C UFLOW - DOUBLE PRECISION C THE SMALLEST POSITIVE MAGNITUDE. C C ON RETURN C RESULT - DOUBLE PRECISION C APPROXIMATION TO THE INTEGRAL I C RESULT IS COMPUTED BY APPLYING THE 15-POINT C KRONROD RULE(RESK) OBTAINED BY OPTIMAL C ADDITION OF ABSCISSAE TO THE 7-POINT GAUSS C RULE(RESG). C C ABSERR - DOUBLE PRECISION C ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR, C WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT) C C RESABS - DOUBLE PRECISION C APPROXIMATION TO THE INTEGRAL J C C RESASC - DOUBLE PRECISION C APPROXIMATION TO THE INTEGRAL OF C ABS((TRANSFORMED INTEGRAND)-I/(B-A)) C OVER (A,B) C C 3. SUBROUTINES OR FUNCTIONS NEEDED C - F (USER-PROVIDED FUNCTION) C C----------------------------------------------------------------------- DOUBLE PRECISION A,ABSC,ABSC1,ABSC2,ABSERR,B,BOUN,CENTR,DINF, * EPMACH,F,FC,FSUM,FVAL1,FVAL2,HLGTH,RESABS,RESASC, * RESG,RESK,RESKH,RESULT,TABSC1,TABSC2,TOL,UFLOW DOUBLE PRECISION FV1(7), FV2(7), XGK(8), WGK(8), WG(8) EXTERNAL F C C THE ABSCISSAE AND WEIGHTS ARE SUPPLIED FOR THE INTERVAL C (-1,1). BECAUSE OF SYMMETRY ONLY THE POSITIVE ABSCISSAE AND C THEIR CORRESPONDING WEIGHTS ARE GIVEN. C C XGK - ABSCISSAE OF THE 15-POINT KRONROD RULE C XGK(2), XGK(4), ... ABSCISSAE OF THE 7-POINT C GAUSS RULE C XGK(1), XGK(3), ... ABSCISSAE WHICH ARE OPTIMALLY C ADDED TO THE 7-POINT GAUSS RULE C C WGK - WEIGHTS OF THE 15-POINT KRONROD RULE C C WG - WEIGHTS OF THE 7-POINT GAUSS RULE, CORRESPONDING C TO THE ABSCISSAE XGK(2), XGK(4), ... C WG(1), WG(3), ... ARE SET TO ZERO. C DATA XGK(1),XGK(2),XGK(3),XGK(4),XGK(5),XGK(6),XGK(7), * XGK(8)/ * 0.991455371120812639206854697526D+00, * 0.949107912342758524526189684048D+00, * 0.864864423359769072789712788641D+00, * 0.741531185599394439863864773281D+00, * 0.586087235467691130294144838259D+00, * 0.405845151377397166906606412077D+00, * 0.207784955007898467600689403773D+00, * 0.000000000000000000000000000000D+00/ C DATA WGK(1),WGK(2),WGK(3),WGK(4),WGK(5),WGK(6),WGK(7), * WGK(8)/ * 0.229353220105292249637320080590D-01, * 0.630920926299785532907006631892D-01, * 0.104790010322250183839876322542D+00, * 0.140653259715525918745189590510D+00, * 0.169004726639267902826583426599D+00, * 0.190350578064785409913256402421D+00, * 0.204432940075298892414161999235D+00, * 0.209482141084727828012999174892D+00/ C DATA WG(1),WG(2),WG(3),WG(4),WG(5),WG(6),WG(7),WG(8)/ * 0.0D+00, 0.129484966168869693270611432679D+00, * 0.0D+00, 0.279705391489276667901467771424D+00, * 0.0D+00, 0.381830050505118944950369775489D+00, * 0.0D+00, 0.417959183673469387755102040816D+00/ C C C LIST OF MAJOR VARIABLES C ----------------------- C C CENTR - MID POINT OF THE INTERVAL C HLGTH - HALF-LENGTH OF THE INTERVAL C ABSC* - ABSCISSA C TABSC* - TRANSFORMED ABSCISSA C FVAL* - FUNCTION VALUE C RESG - RESULT OF THE 7-POINT GAUSS FORMULA C RESK - RESULT OF THE 15-POINT KRONROD FORMULA C RESKH - APPROXIMATION TO THE MEAN VALUE OF THE TRANSFORMED C INTEGRAND OVER (A,B), I.E. TO I/(B-A) C C DINF = MIN0(1,INF) C CENTR = 0.5D0*(A + B) HLGTH = 0.5D0*(B - A) TABSC1 = BOUN + DINF*(1.D0 - CENTR)/CENTR FVAL1 = F(TABSC1) IF (INF .EQ. 2) FVAL1 = FVAL1 + F(-TABSC1) FC = (FVAL1/CENTR)/CENTR C C COMPUTE THE 15-POINT KRONROD APPROXIMATION TO C THE INTEGRAL, AND ESTIMATE THE ERROR. C RESG = WG(8)*FC RESK = WGK(8)*FC RESABS = DABS(RESK) DO 10 J = 1,7 ABSC = HLGTH*XGK(J) ABSC1 = CENTR - ABSC ABSC2 = CENTR + ABSC TABSC1 = BOUN + DINF*(1.D0 - ABSC1)/ABSC1 TABSC2 = BOUN + DINF*(1.D0 - ABSC2)/ABSC2 FVAL1 = F(TABSC1) FVAL2 = F(TABSC2) IF (INF .EQ. 2) FVAL1 = FVAL1 + F(-TABSC1) IF (INF .EQ. 2) FVAL2 = FVAL2 + F(-TABSC2) FVAL1 = (FVAL1/ABSC1)/ABSC1 FVAL2 = (FVAL2/ABSC2)/ABSC2 FV1(J) = FVAL1 FV2(J) = FVAL2 FSUM = FVAL1 + FVAL2 RESG = RESG + WG(J)*FSUM RESK = RESK + WGK(J)*FSUM RESABS = RESABS + WGK(J)*(DABS(FVAL1) + DABS(FVAL2)) 10 CONTINUE RESKH = RESK*0.5D0 RESASC = WGK(8)*DABS(FC - RESKH) DO 20 J = 1,7 RESASC = RESASC + WGK(J)*(DABS(FV1(J)-RESKH) + * DABS(FV2(J)-RESKH)) 20 CONTINUE RESULT = RESK*HLGTH RESASC = RESASC*HLGTH RESABS = RESABS*HLGTH ABSERR = DABS((RESK - RESG)*HLGTH) IF (RESASC .NE. 0.D0 .AND. ABSERR .NE. 0.D0) ABSERR = RESASC* * DMIN1(1.D0, (0.2D+03*ABSERR/RESASC)**1.5D0) TOL = 50.D0*EPMACH IF (RESABS .GT. UFLOW/TOL) ABSERR = DMAX1(ABSERR, TOL*RESABS) RETURN END SUBROUTINE DQPSRT(LIMIT,LAST,MAXERR,ERMAX,ELIST,IORD,NRMAX) C .................................................................. C C 1. DQPSRT C ORDERING ROUTINE C STANDARD FORTRAN SUBROUTINE C DOUBLE PRECISION VERSION C C 2. PURPOSE C THIS ROUTINE MAINTAINS THE DESCENDING ORDERING C IN THE LIST OF THE LOCAL ERROR ESTIMATES RESULTING FROM C THE INTERVAL SUBDIVISION PROCESS. AT EACH CALL TWO ERROR C ESTIMATES ARE INSERTED USING THE SEQUENTIAL SEARCH C METHOD, TOP-DOWN FOR THE LARGEST ERROR ESTIMATE C AND BOTTOM-UP FOR THE SMALLEST ERROR ESTIMATE. C C 3. CALLING SEQUENCE C CALL DQPSRT(LIMIT,LAST,MAXERR,ERMAX,ELIST,IORD,NRMAX) C C PARAMETERS (MEANING AT OUTPUT) C LIMIT - INTEGER C MAXIMUM NUMBER OF ERROR ESTIMATES THE LIST C CAN CONTAIN C C LAST - INTEGER C NUMBER OF ERROR ESTIMATES CURRENTLY C IN THE LIST C C MAXERR - INTEGER C MAXERR POINTS TO THE NRMAX-TH LARGEST ERROR C ESTIMATE CURRENTLY IN THE LIST C C ERMAX - DOUBLE PRECISION C NRMAX-TH LARGEST ERROR ESTIMATE C ERMAX = ELIST(MAXERR) C C ELIST - DOUBLE PRECISION C VECTOR OF DIMENSION LAST CONTAINING C THE ERROR ESTIMATES C C IORD - INTEGER C VECTOR OF DIMENSION LAST, THE FIRST K C ELEMENTS OF WHICH CONTAIN POINTERS C TO THE ERROR ESTIMATES, SUCH THAT C ELIST(IORD(1)),... , ELIST(IORD(K)) C FORM A DECREASING SEQUENCE, WITH C K = LAST IF LAST.LE.(LIMIT/2+2), AND C K = LIMIT+1-LAST OTHERWISE C C NRMAX - INTEGER C MAXERR = IORD(NRMAX) C C 4. NO SUBROUTINES OR FUNCTIONS NEEDED C C .................................................................. C DOUBLE PRECISION ELIST,ERMAX,ERRMAX,ERRMIN INTEGER I,IBEG,IDO,IORD,ISUCC,J,JBND,JUPBN,K,LAST,LIMIT,MAXERR, * NRMAX DIMENSION ELIST(LAST),IORD(LAST) C C CHECK WHETHER THE LIST CONTAINS MORE THAN C TWO ERROR ESTIMATES. C C***FIRST EXECUTABLE STATEMENT DQPSRT IF(LAST.GT.2) GO TO 10 IORD(1) = 1 IORD(2) = 2 GO TO 90 C C THIS PART OF THE ROUTINE IS ONLY EXECUTED C IF, DUE TO A DIFFICULT INTEGRAND, SUBDIVISION C INCREASED THE ERROR ESTIMATE. IN THE NORMAL CASE C THE INSERT PROCEDURE SHOULD START AFTER THE C NRMAX-TH LARGEST ERROR ESTIMATE. C 10 ERRMAX = ELIST(MAXERR) IF(NRMAX.EQ.1) GO TO 30 IDO = NRMAX-1 DO 20 I = 1,IDO ISUCC = IORD(NRMAX-1) C ***JUMP OUT OF DO-LOOP IF(ERRMAX.LE.ELIST(ISUCC)) GO TO 30 IORD(NRMAX) = ISUCC NRMAX = NRMAX-1 20 CONTINUE C C COMPUTE THE NUMBER OF ELEMENTS IN THE LIST TO C BE MAINTAINED IN DESCENDING ORDER. THIS NUMBER C DEPENDS ON THE NUMBER OF SUBDIVISIONS STILL C ALLOWED. C 30 JUPBN = LAST IF(LAST.GT.(LIMIT/2+2)) JUPBN = LIMIT+3-LAST ERRMIN = ELIST(LAST) C C INSERT ERRMAX BY TRAVERSING THE LIST TOP-DOWN, C STARTING COMPARISON FROM THE ELEMENT ELIST(IORD(NRMAX+1)). C JBND = JUPBN-1 IBEG = NRMAX+1 IF(IBEG.GT.JBND) GO TO 50 DO 40 I=IBEG,JBND ISUCC = IORD(I) C ***JUMP OUT OF DO-LOOP IF(ERRMAX.GE.ELIST(ISUCC)) GO TO 60 IORD(I-1) = ISUCC 40 CONTINUE 50 IORD(JBND) = MAXERR IORD(JUPBN) = LAST GO TO 90 C C INSERT ERRMIN BY TRAVERSING THE LIST BOTTOM-UP. C 60 IORD(I-1) = MAXERR K = JBND DO 70 J=I,JBND ISUCC = IORD(K) C ***JUMP OUT OF DO-LOOP IF(ERRMIN.LT.ELIST(ISUCC)) GO TO 80 IORD(K+1) = ISUCC K = K-1 70 CONTINUE IORD(I) = LAST GO TO 90 80 IORD(K+1) = LAST C C SET MAXERR AND ERMAX. C 90 MAXERR = IORD(NRMAX) ERMAX = ELIST(MAXERR) RETURN END SUBROUTINE DQELG (N, EPSTAB, RESULT, ABSERR, RES3LA, NRES, * EPMACH, OFLOW) C----------------------------------------------------------------------- C C 1. PURPOSE C THE ROUTINE DETERMINES THE LIMIT OF A GIVEN SEQUENCE OF C APPROXIMATIONS, BY MEANS OF THE EPSILON ALGORITHM C OF P. WYNN. C AN ESTIMATE OF THE ABSOLUTE ERROR IS ALSO GIVEN. C THE CONDENSED EPSILON TABLE IS COMPUTED. ONLY THOSE C ELEMENTS NEEDED FOR THE COMPUTATION OF THE NEXT DIAGONAL C ARE PRESERVED. C C 2. PARAMETERS C N - INTEGER C EPSTAB(N) CONTAINS THE NEW ELEMENT IN THE C FIRST COLUMN OF THE EPSILON TABLE. C C EPSTAB - DOUBLE PRECISION C VECTOR OF DIMENSION 52 CONTAINING THE C ELEMENTS OF THE TWO LOWER DIAGONALS OF C THE TRIANGULAR EPSILON TABLE C THE ELEMENTS ARE NUMBERED STARTING AT THE C RIGHT-HAND CORNER OF THE TRIANGLE. C C RESULT - DOUBLE PRECISION C RESULTING APPROXIMATION TO THE INTEGRAL C C ABSERR - DOUBLE PRECISION C ESTIMATE OF THE ABSOLUTE ERROR COMPUTED FROM C RESULT AND THE 3 PREVIOUS RESULTS C C RES3LA - DOUBLE PRECISION C VECTOR OF DIMENSION 3 CONTAINING THE LAST 3 C RESULTS C C NRES - INTEGER C NUMBER OF CALLS TO THE ROUTINE C (SHOULD BE ZERO AT FIRST CALL) C C EPMACH - DOUBLE PRECISION C THE RELATIVE PRECISION OF THE FLOATING C ARITHMETIC BEING USED. C C OFLOW - DOUBLE PRECISION C THE LARGEST POSITIVE MAGNITUDE. C C 3. NO SUBROUTINES OR FUNCTIONS USED C C----------------------------------------------------------------------- DOUBLE PRECISION ABSERR,DELTA1,DELTA2,DELTA3,EPMACH,EPSINF, * EPSTAB,ERROR,ERR1,ERR2,ERR3,E0,E1,E1ABS,E2,E3, * OFLOW,RES,RESULT,RES3LA,SS,TOL1,TOL2,TOL3 INTEGER I,IB,IB2,IE,INDX,K1,K2,K3,LIMEXP,N,NEWELM,NRES,NUM DIMENSION EPSTAB(52),RES3LA(3) C--------------------- C C LIST OF MAJOR VARIABLES C ----------------------- C C E0 - THE 4 ELEMENTS ON WHICH THE C E1 COMPUTATION OF A NEW ELEMENT IN C E2 THE EPSILON TABLE IS BASED C E3 E0 C E3 E1 NEW C E2 C NEWELM - NUMBER OF ELEMENTS TO BE COMPUTED IN THE NEW C DIAGONAL C ERROR - ERROR = ABS(E1-E0) + ABS(E2-E1) + ABS(NEW-E2) C RESULT - THE ELEMENT IN THE NEW DIAGONAL WITH LEAST VALUE C OF ERROR C C LIMEXP IS THE MAXIMUM NUMBER OF ELEMENTS THE EPSILON C TABLE CAN CONTAIN. IF THIS NUMBER IS REACHED, THE UPPER C DIAGONAL OF THE EPSILON TABLE IS DELETED. C NRES = NRES + 1 ABSERR = OFLOW RESULT = EPSTAB(N) IF (N .LT. 3) GO TO 100 LIMEXP = 50 EPSTAB(N + 2) = EPSTAB(N) NEWELM = (N - 1)/2 EPSTAB(N) = OFLOW NUM = N K1 = N DO 40 I = 1,NEWELM K2 = K1 - 1 K3 = K1 - 2 RES = EPSTAB(K1 + 2) E0 = EPSTAB(K3) E1 = EPSTAB(K2) E2 = RES E1ABS = DABS(E1) DELTA2 = E2 - E1 ERR2 = DABS(DELTA2) TOL2 = DMAX1(DABS(E2),E1ABS)*EPMACH DELTA3 = E1 - E0 ERR3 = DABS(DELTA3) TOL3 = DMAX1(E1ABS,DABS(E0))*EPMACH IF (ERR2 .GT. TOL2 .OR. ERR3 .GT. TOL3) GO TO 10 C C IF E0, E1 AND E2 ARE EQUAL TO WITHIN MACHINE C ACCURACY, CONVERGENCE IS ASSUMED. C RESULT = E2 C ABSERR = ABS(E1-E0) + ABS(E2-E1) C RESULT = RES ABSERR = ERR2 + ERR3 C ***JUMP OUT OF DO-LOOP GO TO 100 10 E3 = EPSTAB(K1) EPSTAB(K1) = E1 DELTA1 = E1 - E3 ERR1 = DABS(DELTA1) TOL1 = DMAX1(E1ABS,DABS(E3))*EPMACH C C IF TWO ELEMENTS ARE VERY CLOSE TO EACH OTHER, OMIT C A PART OF THE TABLE BY ADJUSTING THE VALUE OF N C IF (ERR1.LE.TOL1 .OR. ERR2.LE.TOL2 .OR. ERR3.LE.TOL3) GO TO 20 SS = 1.D0/DELTA1 + 1.D0/DELTA2 - 1.D0/DELTA3 EPSINF = DABS(SS*E1) C C TEST TO DETECT IRREGULAR BEHAVIOUR IN THE TABLE, AND C EVENTUALLY OMIT A PART OF THE TABLE ADJUSTING THE VALUE C OF N. C IF (EPSINF .GT. 0.1D-03) GO TO 30 20 N = I + I - 1 C ***JUMP OUT OF DO-LOOP GO TO 50 C C COMPUTE A NEW ELEMENT AND EVENTUALLY ADJUST C THE VALUE OF RESULT. C 30 RES = E1 + 1.D0/SS EPSTAB(K1) = RES K1 = K1 - 2 ERROR = ERR2 + DABS(RES - E2) + ERR3 IF (ERROR .GT. ABSERR) GO TO 40 ABSERR = ERROR RESULT = RES 40 CONTINUE C C SHIFT THE TABLE. C 50 IF (N .EQ. LIMEXP) N = 2*(LIMEXP/2) - 1 IB = 1 IF ((NUM/2)*2 .EQ. NUM) IB = 2 IE = NEWELM + 1 DO 60 I = 1,IE IB2 = IB + 2 EPSTAB(IB) = EPSTAB(IB2) IB = IB2 60 CONTINUE IF (NUM .EQ. N) GO TO 80 INDX = NUM - N + 1 DO 70 I = 1,N EPSTAB(I) = EPSTAB(INDX) INDX = INDX + 1 70 CONTINUE 80 IF (NRES .GE. 4) GO TO 90 RES3LA(NRES) = RESULT ABSERR = OFLOW GO TO 100 C C COMPUTE ERROR ESTIMATE C 90 ABSERR = DABS(RESULT - RES3LA(3)) + DABS(RESULT - RES3LA(2)) + * DABS(RESULT - RES3LA(1)) RES3LA(1) = RES3LA(2) RES3LA(2) = RES3LA(3) RES3LA(3) = RESULT 100 ABSERR = DMAX1(ABSERR,5.D0*EPMACH*DABS(RESULT)) RETURN END SUBROUTINE DQXGS (F,A,B,EPSABS,EPSREL,RESULT,ABSERR,IER, * LIMIT,LENIW,LENW,LAST,IWORK,WORK) C C THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO A GIVEN C DEFINITE INTEGRAL I = INTEGRAL OF F OVER (A,B), C HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY C DABS(I-RESULT).LE.MAX(EPSABS,EPSREL*DABS(I)). C C PARAMETERS C ON ENTRY C F - DOUBLE PRECISION C FUNCTION SUBPROGRAM DEFINING THE INTEGRAND C FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE C DECLARED E X T E R N A L IN THE DRIVER PROGRAM. C C A - DOUBLE PRECISION C LOWER LIMIT OF INTEGRATION C C B - DOUBLE PRECISION C UPPER LIMIT OF INTEGRATION C C EPSABS - DOUBLE PRECISION C ABSOLUTE ACCURACY REQUESTED C C EPSREL - DOUBLE PRECISION C RELATIVE ACCURACY REQUESTED C C ON RETURN C RESULT - DOUBLE PRECISION C APPROXIMATION TO THE INTEGRAL C C ABSERR - DOUBLE PRECISION C ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR, C WHICH SHOULD EQUAL OR EXCEED DABS(I-RESULT) C C IER - INTEGER C IER = 0 NORMAL AND RELIABLE TERMINATION OF THE C ROUTINE. IT IS ASSUMED THAT THE REQUESTED C ACCURACY HAS BEEN ACHIEVED. C IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE C THE ESTIMATES FOR INTEGRAL AND ERROR ARE C LESS RELIABLE. IT IS ASSUMED THAT THE C REQUESTED ACCURACY HAS NOT BEEN ACHIEVED. C ERROR MESSAGES C IER = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED C HAS BEEN ACHIEVED. ONE CAN ALLOW MORE SUB- C DIVISIONS BY INCREASING THE VALUE OF LIMIT C (AND TAKING THE ACCORDING DIMENSION C ADJUSTMENTS INTO ACCOUNT. HOWEVER, IF C THIS YIELDS NO IMPROVEMENT IT IS ADVISED C TO ANALYZE THE INTEGRAND IN ORDER TO C DETERMINE THE INTEGRATION DIFFICULTIES. IF C THE POSITION OF A LOCAL DIFFICULTY CAN BE C DETERMINED (E.G. SINGULARITY, C DISCONTINUITY WITHIN THE INTERVAL) ONE C WILL PROBABLY GAIN FROM SPLITTING UP THE C INTERVAL AT THIS POINT AND CALLING THE C INTEGRATOR ON THE SUBRANGES. IF POSSIBLE, C AN APPROPRIATE SPECIAL-PURPOSE INTEGRATOR C SHOULD BE USED, WHICH IS DESIGNED FOR C HANDLING THE TYPE OF DIFFICULTY INVOLVED. C = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS DETEC- C TED, WHICH PREVENTS THE REQUESTED C TOLERANCE FROM BEING ACHIEVED. C THE ERROR MAY BE UNDER-ESTIMATED. C = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR C OCCURS AT SOME POINTS OF THE INTEGRATION C INTERVAL. C = 4 THE ALGORITHM DOES NOT CONVERGE. C ROUNDOFF ERROR IS DETECTED IN THE C EXTRAPOLATION TABLE. IT IS PRESUMED THAT C THE REQUESTED TOLERANCE CANNOT BE C ACHIEVED, AND THAT THE RETURNED RESULT IS C THE BEST WHICH CAN BE OBTAINED. C = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR C SLOWLY CONVERGENT. IT MUST BE NOTED THAT C DIVERGENCE CAN OCCUR WITH ANY OTHER VALUE C OF IER. C = 6 THE INPUT IS INVALID BECAUSE EPSABS OR C EPSREL IS NEGATIVE, LIMIT .LT. 1, C LENW .LT. 46*LIMIT, OR C LENIW .LT. 3*LIMIT. C RESULT, ABSERR, LAST ARE SET TO C ZERO. EXCEPT WHEN LIMIT OR LENW OR LENIW C IS INVALID, IWORK(1), WORK(LIMIT*2+1) AND C WORK(LIMIT*3+1) ARE SET TO ZERO, WORK(1) C IS SET TO A, AND WORK(LIMIT+1) TO B. C C DIMENSIONING PARAMETERS C LIMIT - INTEGER C LIMIT DETERMINES THE MAXIMUM NUMBER OF SUBINTERVALS C IN THE PARTITION OF THE GIVEN INTEGRATION INTERVAL C (A,B), LIMIT.GE.1. C IF LIMIT.LT.1, THE ROUTINE WILL END WITH IER = 6. C C LENW - INTEGER C DIMENSIONING PARAMETER FOR WORK C LENW MUST BE AT LEAST LIMIT*46. C IF LENW.LT.LIMIT*46, THE ROUTINE WILL END C WITH IER = 6. C C LENIW - INTEGER C DIMENSIONING PARAMETER FOR IWORK C LENIW MUST BE AT LEAST LIMIT*3. C IF LENW.LT.LIMIT*3, THE ROUTINE WILL END C WITH IER = 6. C C LAST - INTEGER C ON RETURN, LAST EQUALS THE NUMBER OF SUBINTERVALS C PRODUCED IN THE SUBDIVISION PROCESS, WHICH DETER- C MINES THE NUMBER OF SIGNIFICANT ELEMENTS ACTUALLY C IN THE WORK ARRAYS. C C WORK ARRAYS C IWORK - INTEGER C VECTOR OF DIMENSION AT LEAST 3*LIMIT, THE FIRST K C ELEMENTS OF WHICH CONTAIN POINTERS C TO THE ERROR ESTIMATES OVER THE SUBINTERVALS C SUCH THAT WORK(LIMIT*3+IWORK(1)),... , C WORK(LIMIT*3+IWORK(K)) FORM A DECREASING C SEQUENCE, WITH K = LAST IF LAST.LE.(LIMIT/2+2), C AND K = LIMIT+1-LAST OTHERWISE. C C WORK - DOUBLE PRECISION C VECTOR OF DIMENSION AT LEAST LENW C ON RETURN C WORK(1), ..., WORK(LAST) CONTAIN THE LEFT C END-POINTS OF THE SUBINTERVALS IN THE C PARTITION OF (A,B), C WORK(LIMIT+1), ..., WORK(LIMIT+LAST) CONTAIN C THE RIGHT END-POINTS, C WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) CONTAIN C THE INTEGRAL APPROXIMATIONS OVER THE SUBINTERVALS, C WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST) C CONTAIN THE ERROR ESTIMATES. C WORK(LIMIT*4+1), ... IS THE AREA RESERVED TO STORE C FUNCTIONAL VALUES. C DOUBLE PRECISION A,ABSERR,B,EPSABS,EPSREL,F,RESULT,WORK INTEGER IER,IWORK,LAST,LENIW,LENW,LIMIT,L1,L2,L3,L4,L5 C DIMENSION IWORK(LENIW),WORK(LENW) C EXTERNAL F C C CHECK VALIDITY OF LIMIT,LENIW AND LENW. C IER = 6 LAST = 0 RESULT = 0.D0 ABSERR = 0.D0 IF (LIMIT.LT.1 .OR. LENIW.LT.LIMIT*3 .OR. LENW.LT.LIMIT*46) * RETURN C C PREPARE CALL FOR DQXGSE. C L1 = LIMIT + 1 L2 = LIMIT + L1 L3 = LIMIT + L2 L4 = LIMIT + L3 L5 = 21*LIMIT + L4 C CALL DQXGSE(F,A,B,EPSABS,EPSREL,LIMIT,RESULT,ABSERR, * IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST, * WORK(L4),WORK(L5),IWORK(L1),IWORK(L2)) C RETURN END SUBROUTINE DQXGSE(F,A,B,EPSABS,EPSREL,LIMIT,RESULT,ABSERR, * IER,ALIST,BLIST,RLIST,ELIST,IORD,LAST,VALP,VALN,LP,LN) C C THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO A C DEFINITE INTEGRAL I = INTEGRAL OF F OVER (A,B), C HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY C DABS(I-RESULT).LE.MAX(EPSABS,EPSREL*DABS(I)). C C PARAMETERS C ON ENTRY C F - DOUBLE PRECISION C FUNCTION SUBPROGRAM DEFINING THE INTEGRAND C FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE C DECLARED E X T E R N A L IN THE DRIVER PROGRAM. C C A - DOUBLE PRECISION C LOWER LIMIT OF INTEGRATION C C B - DOUBLE PRECISION C UPPER LIMIT OF INTEGRATION C C EPSABS - DOUBLE PRECISION C ABSOLUTE ACCURACY REQUESTED C C EPSREL - DOUBLE PRECISION C RELATIVE ACCURACY REQUESTED C C LIMIT - INTEGER C GIVES AN UPPERBOUND ON THE NUMBER OF SUBINTERVALS C IN THE PARTITION OF (A,B) C C ON RETURN C RESULT - DOUBLE PRECISION C APPROXIMATION TO THE INTEGRAL C C ABSERR - DOUBLE PRECISION C ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR, C WHICH SHOULD EQUAL OR EXCEED DABS(I-RESULT) C C IER - INTEGER C IER = 0 NORMAL AND RELIABLE TERMINATION OF THE C ROUTINE. IT IS ASSUMED THAT THE REQUESTED C ACCURACY HAS BEEN ACHIEVED. C IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE C THE ESTIMATES FOR INTEGRAL AND ERROR ARE C LESS RELIABLE. IT IS ASSUMED THAT THE C REQUESTED ACCURACY HAS NOT BEEN ACHIEVED. C ERROR MESSAGES C = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED C HAS BEEN ACHIEVED. ONE CAN ALLOW MORE SUB- C DIVISIONS BY INCREASING THE VALUE OF LIMIT C (AND TAKING THE ACCORDING DIMENSION C ADJUSTMENTS INTO ACCOUNT). HOWEVER, IF C THIS YIELDS NO IMPROVEMENT IT IS ADVISED C TO ANALYZE THE INTEGRAND IN ORDER TO C DETERMINE THE INTEGRATION DIFFICULTIES. IF C THE POSITION OF A LOCAL DIFFICULTY CAN BE C DETERMINED (E.G. SINGULARITY, C DISCONTINUITY WITHIN THE INTERVAL) ONE C WILL PROBABLY GAIN FROM SPLITTING UP THE C INTERVAL AT THIS POINT AND CALLING THE C INTEGRATOR ON THE SUBRANGES. IF POSSIBLE, C AN APPROPRIATE SPECIAL-PURPOSE INTEGRATOR C SHOULD BE USED, WHICH IS DESIGNED FOR C HANDLING THE TYPE OF DIFFICULTY INVOLVED. C = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS DETEC- C TED, WHICH PREVENTS THE REQUESTED C TOLERANCE FROM BEING ACHIEVED. C THE ERROR MAY BE UNDER-ESTIMATED. C = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR C OCCURS AT SOME POINTS OF THE INTEGRATION C INTERVAL. C = 4 THE ALGORITHM DOES NOT CONVERGE. C ROUNDOFF ERROR IS DETECTED IN THE C EXTRAPOLATION TABLE. C IT IS PRESUMED THAT THE REQUESTED C TOLERANCE CANNOT BE ACHIEVED, AND THAT THE C RETURNED RESULT IS THE BEST WHICH CAN BE C OBTAINED. C = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR C SLOWLY CONVERGENT. IT MUST BE NOTED THAT C DIVERGENCE CAN OCCUR WITH ANY OTHER VALUE C OF IER. C = 6 THE INPUT IS INVALID BECAUSE EPSABS OR C EPSREL IS NEGATIVE. RESULT, ABSERR, C LAST, RLIST(1), IORD(1), AND ELIST(1) C ARE SET TO ZERO. ALIST(1) AND BLIST(1) C ARE SET TO A AND B RESPECTIVELY. C C ALIST - DOUBLE PRECISION C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST C LAST ELEMENTS OF WHICH ARE THE LEFT END POINTS C OF THE SUBINTERVALS IN THE PARTITION OF THE C GIVEN INTEGRATION RANGE (A,B) C C BLIST - DOUBLE PRECISION C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST C LAST ELEMENTS OF WHICH ARE THE RIGHT END POINTS C OF THE SUBINTERVALS IN THE PARTITION OF THE GIVEN C INTEGRATION RANGE (A,B) C C RLIST - DOUBLE PRECISION C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST C LAST ELEMENTS OF WHICH ARE THE INTEGRAL C APPROXIMATIONS ON THE SUBINTERVALS C C ELIST - DOUBLE PRECISION C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST C LAST ELEMENTS OF WHICH ARE THE MODULI OF THE C ABSOLUTE ERROR ESTIMATES ON THE SUBINTERVALS C C IORD - INTEGER C VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST K C ELEMENTS OF WHICH ARE POINTERS TO THE C ERROR ESTIMATES OVER THE SUBINTERVALS, C SUCH THAT ELIST(IORD(1)), ..., ELIST(IORD(K)) C FORM A DECREASING SEQUENCE, WITH K = LAST C IF LAST.LE.(LIMIT/2+2), AND K = LIMIT+1-LAST C OTHERWISE C C LAST - INTEGER C NUMBER OF SUBINTERVALS ACTUALLY PRODUCED IN THE C SUBDIVISION PROCESS C C VALP - DOUBLE PRECISION C VALN ARRAYS OF DIMENSION AT LEAST (21,LIMIT) USED TO C SAVE THE FUNCTIONAL VALUES C C LP - INTEGER C LN VECTORS OF DIMENSION AT LEAST LIMIT, USED TO C STORE THE ACTUAL NUMBER OF FUNCTIONAL VALUES C SAVED IN THE CORRESPONDING COLUMN C OF VALP,VALN C C***ROUTINES CALLED F,DPMPAR,DQELG,DQXLQM,DQPSRT,DQXRRD,DQXCPY C DOUBLE PRECISION * A,ABSEPS,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1,A2, * B,BLIST,B1,B2,CORREC,DEFABS,DEFAB1,DEFAB2,DRES,ELIST, * EPMACH,EPSABS,EPSREL,ERLARG,ERLAST,ERRBND,ERRMAX, * ERROR1,ERROR2,ERRO12,ERRSUM,ERTEST,F,OFLOW,RERR,RESABS, * RESEPS,RESULT,RES3LA,RLIST,RLIST2,SMALL,T,UFLOW, * VALP,VALN,VP1,VP2,VN1,VN2,DPMPAR INTEGER ID,IER,IERRO,IORD,IROFF1,IROFF2,IROFF3,JUPBND,K,KSGN, * KTMIN,LAST,LIMIT,MAXERR,NRES,NRMAX,NUMRL2, * LP,LN,LP1,LP2,LN1,LN2 LOGICAL EXTRAP,NOEXT C DIMENSION ALIST(LIMIT),BLIST(LIMIT),ELIST(LIMIT),IORD(LIMIT), * RES3LA(3),RLIST(LIMIT),RLIST2(52), * VALP(21,LIMIT),VALN(21,LIMIT),LP(LIMIT),LN(LIMIT), * VP1(21),VP2(21),VN1(21),VN2(21) C EXTERNAL F C C MACHINE DEPENDENT CONSTANTS C --------------------------- C C EPMACH IS THE LARGEST RELATIVE SPACING. C UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. C OFLOW IS THE LARGEST POSITIVE MAGNITUDE. C EPMACH = DPMPAR(1) UFLOW = DPMPAR(2) OFLOW = DPMPAR(3) C C TEST ON VALIDITY OF PARAMETERS C ------------------------------ LAST = 0 RESULT = 0.D0 ABSERR = 0.D0 ALIST(1) = A BLIST(1) = B RLIST(1) = 0.D0 ELIST(1) = 0.D0 IER = 6 IF (EPSABS .LT. 0.D0 .OR. EPSREL.LT. 0.D0) GO TO 999 IER = 0 RERR = DMAX1(EPSREL, 50.D0*EPMACH) C C FIRST APPROXIMATION TO THE INTEGRAL C ----------------------------------- C IERRO = 0 LP(1) = 1 LN(1) = 1 VALP(1,1) = F((A + B)*0.5D0) VALN(1,1) = VALP(1,1) CALL DQXLQM (F,A,B,RESULT,ABSERR,DEFABS,RESABS, * VALP(1,1),VALN(1,1),LP(1),LN(1),2, * EPMACH,UFLOW,OFLOW) C C TEST ON ACCURACY. C DRES = DABS(RESULT) ERRBND = DMAX1(EPSABS,RERR*DRES) LAST = 1 RLIST(1) = RESULT ELIST(1) = ABSERR IORD(1) = 1 IF (ABSERR .LE. 100.D0*EPMACH*DEFABS .AND. ABSERR .GT. * ERRBND) IER = 2 IF (LIMIT .EQ. 1) IER = 1 IF (IER .NE. 0 .OR. (ABSERR.LE.ERRBND.AND.ABSERR.NE.RESABS) .OR. * ABSERR .EQ. 0.D0) GO TO 999 C C INITIALIZATION C -------------- C RLIST2(1) = RESULT ERRMAX = ABSERR MAXERR = 1 AREA = RESULT ERRSUM = ABSERR ABSERR = OFLOW NRMAX = 1 NRES = 0 NUMRL2 = 2 KTMIN = 0 EXTRAP = .FALSE. NOEXT = .FALSE. IROFF1 = 0 IROFF2 = 0 IROFF3 = 0 KSGN = -1 IF (DRES .GE. (1.D0 - 50.D0*EPMACH)*DEFABS) KSGN = 1 T = 1.D0 + 100.D0*EPMACH C C MAIN DO-LOOP C ------------ C DO 90 LAST = 2,LIMIT C C BISECT THE SUBINTERVAL WITH THE NRMAX-TH LARGEST ERROR C ESTIMATE. C A1 = ALIST(MAXERR) B1 = 0.5D0*(ALIST(MAXERR) + BLIST(MAXERR)) A2 = B1 B2 = BLIST(MAXERR) ERLAST = ERRMAX CALL DQXRRD(F,VALN(1,MAXERR),LN(MAXERR),B1,A1,VN1,VP1,LN1,LP1) CALL DQXLQM(F,A1,B1,AREA1,ERROR1,RESABS,DEFAB1,VP1,VN1,LP1,LN1, * 2,EPMACH,UFLOW,OFLOW) CALL DQXRRD(F,VALP(1,MAXERR),LP(MAXERR),A2,B2,VP2,VN2,LP2,LN2) CALL DQXLQM(F,A2,B2,AREA2,ERROR2,RESABS,DEFAB2,VP2,VN2,LP2,LN2, * 2,EPMACH,UFLOW,OFLOW) C C IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL C AND ERROR AND TEST FOR ACCURACY. C AREA12 = AREA1 + AREA2 ERRO12 = ERROR1 + ERROR2 ERRSUM = ERRSUM + ERRO12 - ERRMAX AREA = AREA + AREA12 - RLIST(MAXERR) IF (DEFAB1 .EQ. ERROR1 .OR. DEFAB2 .EQ. ERROR2) GO TO 15 IF (DABS(RLIST(MAXERR) - AREA12) .GT. 0.1D-04*DABS(AREA12) * .OR. ERRO12 .LT. 0.99D0*ERRMAX) GO TO 10 IF (EXTRAP) IROFF2 = IROFF2 + 1 IF (.NOT.EXTRAP) IROFF1 = IROFF1 + 1 10 IF (LAST.GT.10 .AND. ERRO12.GT.ERRMAX) IROFF3 = IROFF3 + 1 15 RLIST(MAXERR) = AREA1 RLIST(LAST) = AREA2 ERRBND = DMAX1(EPSABS,RERR*DABS(AREA)) C C TEST FOR ROUNDOFF ERROR AND EVENTUALLY SET ERROR FLAG. C IF (IROFF1 + IROFF2 .GE. 10 .OR. IROFF3 .GE. 20) IER = 2 IF (IROFF2 .GE. 5) IERRO = 3 C C SET ERROR FLAG IN THE CASE THAT THE NUMBER OF SUBINTERVALS C EQUALS LIMIT. C IF (LAST .EQ. LIMIT) IER = 1 C C SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR C AT A POINT OF THE INTEGRATION RANGE. C IF (DMAX1(DABS(A1),DABS(B2)) .LE. * T*(DABS(A2) + 1.D+03*UFLOW)) IER = 4 C C APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. C IF (ERROR2 .GT. ERROR1) GO TO 20 ALIST(LAST) = A2 BLIST(MAXERR) = B1 BLIST(LAST) = B2 ELIST(MAXERR) = ERROR1 ELIST(LAST) = ERROR2 CALL DQXCPY(VALP(1,MAXERR),VP1,LP1) LP(MAXERR) = LP1 CALL DQXCPY(VALN(1,MAXERR),VN1,LN1) LN(MAXERR) = LN1 CALL DQXCPY(VALP(1,LAST),VP2,LP2) LP(LAST) = LP2 CALL DQXCPY(VALN(1,LAST),VN2,LN2) LN(LAST) = LN2 GO TO 30 C 20 ALIST(MAXERR) = A2 ALIST(LAST) = A1 BLIST(LAST) = B1 RLIST(MAXERR) = AREA2 RLIST(LAST) = AREA1 ELIST(MAXERR) = ERROR2 ELIST(LAST) = ERROR1 CALL DQXCPY(VALP(1,MAXERR),VP2,LP2) LP(MAXERR) = LP2 CALL DQXCPY(VALN(1,MAXERR),VN2,LN2) LN(MAXERR) = LN2 CALL DQXCPY(VALP(1,LAST),VP1,LP1) LP(LAST) = LP1 CALL DQXCPY(VALN(1,LAST),VN1,LN1) LN(LAST) = LN1 C C CALL SUBROUTINE DQPSRT TO MAINTAIN THE DESCENDING ORDERING C IN THE LIST OF ERROR ESTIMATES AND SELECT THE SUBINTERVAL C WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE BISECTED NEXT). C 30 CALL DQPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX) C ***JUMP OUT OF DO-LOOP IF(ERRSUM .LE. ERRBND) GO TO 115 C ***JUMP OUT OF DO-LOOP IF (IER .NE. 0) GO TO 100 IF (LAST .EQ. 2) GO TO 80 IF (NOEXT) GO TO 90 ERLARG = ERLARG - ERLAST IF (DABS(B1 - A1) .GT. SMALL) ERLARG = ERLARG + ERRO12 IF (EXTRAP) GO TO 40 C C TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE C SMALLEST INTERVAL. C IF (DABS(BLIST(MAXERR) - ALIST(MAXERR)) .GT. SMALL) GO TO 90 EXTRAP = .TRUE. NRMAX = 2 C C THE BOUND 0.3*ERTEST HAS BEEN INTRODUCED TO PERFORM A C MORE CAUTIOUS EXTRAPOLATION THAN IN THE ORIGINAL DQAGSE C ROUTINE C 40 IF (IERRO .EQ. 3 .OR. ERLARG .LE. 0.3D0*ERTEST) GO TO 60 C C THE SMALLEST INTERVAL HAS THE LARGEST ERROR. C BEFORE BISECTING DECREASE THE SUM OF THE ERRORS OVER THE C LARGER INTERVALS (ERLARG) AND PERFORM EXTRAPOLATION. C ID = NRMAX JUPBND = LAST IF (LAST .GT. (2 + LIMIT/2)) JUPBND = LIMIT + 3 - LAST DO 50 K = ID,JUPBND MAXERR = IORD(NRMAX) ERRMAX = ELIST(MAXERR) C ***JUMP OUT OF DO-LOOP IF(DABS(BLIST(MAXERR) - ALIST(MAXERR)) .GT. SMALL) GO TO 90 NRMAX = NRMAX + 1 50 CONTINUE C C PERFORM EXTRAPOLATION. C 60 NUMRL2 = NUMRL2 + 1 RLIST2(NUMRL2) = AREA CALL DQELG (NUMRL2,RLIST2,RESEPS,ABSEPS,RES3LA,NRES, * EPMACH,OFLOW) KTMIN = KTMIN + 1 IF (KTMIN .GT. 5 .AND. ABSERR .LT. 0.1D-02*ERRSUM) IER = 5 IF (ABSEPS .GE. ABSERR) GO TO 70 KTMIN = 0 ABSERR = ABSEPS RESULT = RESEPS CORREC = ERLARG ERTEST = DMAX1(EPSABS,RERR*DABS(RESEPS)) C ***JUMP OUT OF DO-LOOP IF (ABSERR .LE. ERTEST) GO TO 100 C C PREPARE BISECTION OF THE SMALLEST INTERVAL. C 70 IF (NUMRL2 .EQ. 1) NOEXT = .TRUE. IF (IER .EQ. 5) GO TO 100 MAXERR = IORD(1) ERRMAX = ELIST(MAXERR) NRMAX = 1 EXTRAP = .FALSE. SMALL = SMALL*0.5D0 ERLARG = ERRSUM GO TO 90 80 SMALL = DABS(B - A)*0.375D0 ERLARG = ERRSUM ERTEST = ERRBND RLIST2(2) = AREA 90 CONTINUE C C SET FINAL RESULT AND ERROR ESTIMATE. C ------------------------------------ C 100 IF (ABSERR .EQ. OFLOW) GO TO 115 IF (IER + IERRO .EQ. 0) GO TO 110 IF (IERRO .EQ. 3) ABSERR = ABSERR + CORREC IF (IER .EQ. 0) IER = 3 IF (RESULT .NE. 0.D0 .AND. AREA .NE. 0.D0) GO TO 105 IF (ABSERR .GT. ERRSUM) GO TO 115 IF (AREA .EQ. 0.D0) GO TO 130 GO TO 110 105 IF (ABSERR/DABS(RESULT) .GT. ERRSUM/DABS(AREA)) GO TO 115 C C TEST ON DIVERGENCE. C 110 IF(KSGN.EQ.(-1).AND.DMAX1(DABS(RESULT),DABS(AREA)).LE. * DEFABS*0.1D-01) GO TO 130 IF(0.1D-01.GT.(RESULT/AREA).OR.(RESULT/AREA).GT.0.1D+03 * .OR.ERRSUM.GT.DABS(AREA)) IER = 6 GO TO 130 C C COMPUTE GLOBAL INTEGRAL SUM. C 115 RESULT = 0.D0 DO 120 K = 1,LAST RESULT = RESULT + RLIST(K) 120 CONTINUE ABSERR = ERRSUM 130 IF (IER .GT. 2) IER = IER - 1 999 RETURN END SUBROUTINE DQXCPY (A, B, L) C C TO COPY THE DOUBLE PRECISION VECTOR B OF LENGTH L I N T O C THE DOUBLE PRECISION VECTOR A OF LENGTH L C INTEGER L DOUBLE PRECISION A(L),B(L) C DO 10 I = 1,L 10 A(I) = B(I) RETURN END SUBROUTINE DQXLQM (F,A,B,RESULT,ABSERR,RESABS,RESASC,VR,VS,LR,LS, * KEY,EPMACH,UFLOW,OFLOW) C C TO COMPUTE I = INTEGRAL OF F OVER (A,B), WITH ERROR C ESTIMATE C J = INTEGRAL OF DABS(F) OVER (A,B) C C PARAMETERS C ON ENTRY C F - DOUBLE PRECISION C FUNCTION SUBPROGRAM DEFINING THE INTEGRAND C FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE C DECLARED E X T E R N A L IN THE DRIVER PROGRAM. C C A - DOUBLE PRECISION C LOWER LIMIT OF INTEGRATION C C B - DOUBLE PRECISION C UPPER LIMIT OF INTEGRATION C C VR - DOUBLE PRECISION C VECTOR OF LENGTH LR CONTAINING THE C SAVED FUNCTIONAL VALUES OF POSITIVE ABSCISSAS C C VS - DOUBLE PRECISION C VECTOR OF LENGTH LS CONTAINING THE C SAVED FUNCTIONAL VALUES OF NEGATIVE ABSCISSAS C C LR - INTEGER C LS NUMBER OF ELEMENTS IN C VR,VS RESPECTIVELY C C KEY - INTEGER C KEY FOR CHOICE OF LOCAL INTEGRATION RULE C RMS FORMULAS ARE USED WITH C 13 - 19 POINTS IF KEY.LT.1, C 13 - 19 - (27) POINTS IF KEY = 1, C 13 - 19 - (27) - (41) POINTS IF KEY = 2, C 19 - 27 - (41) POINTS IF KEY = 3, C 27 - 41 POINTS IF KEY.GT.3. C C (RULES) USED IF THE FUNCTION APPEARS C ENOUGH REGULAR C C EPMACH - DOUBLE PRECISION C THE RELATIVE PRECISION OF THE FLOATING C ARITHMETIC BEING USED. C C UFLOW - DOUBLE PRECISION C THE SMALLEST POSITIVE MAGNITUDE. C C OFLOW - DOUBLE PRECISION C THE LARGEST POSITIVE MAGNITUDE. C C ON RETURN C RESULT - DOUBLE PRECISION C APPROXIMATION TO THE INTEGRAL I C C ABSERR - DOUBLE PRECISION C ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR, C WHICH SHOULD NOT EXCEED DABS(I-RESULT) C C RESABS - DOUBLE PRECISION C APPROXIMATION TO THE INTEGRAL J C C RESASC - DOUBLE PRECISION C APPROXIMATION TO THE INTEGRAL OF DABS(F-I/(B-A)) C OVER (A,B) C C VR - DOUBLE PRECISION C VECTOR OF LENGTH LR CONTAINING THE C SAVED FUNCTIONAL VALUES OF POSITIVE ABSCISSAS C C VS - DOUBLE PRECISION C VECTOR OF LENGTH LS CONTAINING THE C SAVED FUNCTIONAL VALUES OF NEGATIVE ABSCISSAS C C LR - INTEGER C LS NUMBER OF ELEMENTS IN C VR,VS RESPECTIVELY C C***ROUTINES CALLED DQXRUL C DOUBLE PRECISION F,A,B,RESULT,ABSERR,RESABS,RESASC, T, * EPMACH,OFLOW,UFLOW,RESG,RESK,ERROLD,VR(21),VS(21) INTEGER K,K0,K1,K2,KEY,KEY1,LR,LS EXTERNAL F C KEY1 = MAX0(KEY , 0) KEY1 = MIN0(KEY1, 4) K0 = MAX0(KEY1-2,0) K1 = K0 + 1 K2 = MIN0(KEY1+1,3) C CALL DQXRUL (F,A,B,RESG,RESABS,RESASC,K0,K1,VR,VS,LR,LS) ERROLD = OFLOW T = 10.D0*EPMACH DO 10 K = K1,K2 CALL DQXRUL (F,A,B,RESK,RESABS,RESASC,K,K1,VR,VS,LR,LS) RESULT = RESK ABSERR = DABS(RESK - RESG) IF (RESASC .NE. 0.D0 .AND. ABSERR .NE. 0.D0) * ABSERR = RESASC*DMIN1(1.D0,(200.D0*ABSERR/RESASC)**1.5D0) IF (RESABS .GT. UFLOW/T) ABSERR = DMAX1(T*RESABS,ABSERR) RESG = RESK IF (ABSERR .GT. ERROLD*0.16D0) GO TO 3000 IF (ABSERR .LT. 1000.D0*EPMACH*RESABS) GO TO 3000 ERROLD = ABSERR 10 CONTINUE 3000 CONTINUE RETURN END SUBROUTINE DQXRUL (F,XL,XU,Y,YA,YM,KE,K1,FV1,FV2,L1,L2) C C TO COMPUTE I = INTEGRAL OF F OVER (A,B), WITH ERROR C ESTIMATE C AND CONDITIONALLY COMPUTE C J = INTEGRAL OF DABS(F) OVER (A,B) C BY USING AN RMS RULE C PARAMETERS C ON ENTRY C F - DOUBLE PRECISION C FUNCTION SUBPROGRAM DEFINING THE INTEGRAND C FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE C DECLARED E X T E R N A L IN THE DRIVER PROGRAM. C C XL - DOUBLE PRECISION C LOWER LIMIT OF INTEGRATION C C XU - DOUBLE PRECISION C UPPER LIMIT OF INTEGRATION C C KE - INTEGER C KEY FOR CHOICE OF LOCAL INTEGRATION RULE C AN RMS RULE IS USED WITH C 13 POINTS IF KE = 2, C 19 POINTS IF KE = 3, C 27 POINTS IF KE = 4, C 42 POINTS IF KE = 5 C C K1 INTEGER C VALUE OF KEY FOR WHICH THE ADDITIONAL ESTIMATES C YA, YM ARE TO BE COMPUTED C C FV1 - DOUBLE PRECISION C VECTOR CONTAINING L1 C SAVED FUNCTIONAL VALUES OF POSITIVE ABSCISSAS C C FV2 - DOUBLE PRECISION C VECTOR CONTAINING L2 C SAVED FUNCTIONAL VALUES OF NEGATIVE ABSCISSAS C C L1 - INTEGER C L2 NUMBER OF ELEMENTS IN FV1,FV2 RESPECTIVELY C C ON RETURN C Y - DOUBLE PRECISION C APPROXIMATION TO THE INTEGRAL I C RESULT IS COMPUTED BY APPLYING THE C REQUESTED RMS RULE C C YA - DOUBLE PRECISION C IF KEY = K1 APPROXIMATION TO THE INTEGRAL J C ELSE UNCHANGED C C YM - DOUBLE PRECISION C IF KEY = K1 APPROXIMATION TO THE INTEGRAL OF C DABS(F-I/(XU-XL) OVER (XL,XU) C ELSE UNCHANGED C C FV1 - DOUBLE PRECISION C VECTOR CONTAINING L1 C SAVED FUNCTIONAL VALUES OF POSITIVE ABSCISSAS C C FV2 - DOUBLE PRECISION C VECTOR CONTAINING L2 C SAVED FUNCTIONAL VALUES OF NEGATIVE ABSCISSAS C C L1 - INTEGER C L2 NUMBER OF ELEMENTS IN FV1,FV2 RESPECTIVELY C C------------------------ DOUBLE PRECISION F,XL,XU,LDL,Y,YA,YM,Y2,XX(41),WW(52), * FV1(21),FV2(21),AA,BB,C INTEGER ISTART(4),LEN(4),J,KE,K1,L1,L2 EXTERNAL F C------------------------ DATA ISTART(1)/0/, ISTART(2)/7/, ISTART(3)/17/, ISTART(4)/31/ DATA LEN(1)/7/, LEN(2)/10/, LEN(3)/14/, LEN(4)/21/ C------------------------ DATA XX( 1)/0.D0 / DATA XX( 2)/.25000000000000000000D+00/ DATA XX( 3)/.50000000000000000000D+00/ DATA XX( 4)/.75000000000000000000D+00/ DATA XX( 5)/.87500000000000000000D+00/ DATA XX( 6)/.93750000000000000000D+00/ DATA XX( 7)/.10000000000000000000D+01/ DATA XX( 8)/.37500000000000000000D+00/ DATA XX( 9)/.62500000000000000000D+00/ DATA XX(10)/.96875000000000000000D+00/ DATA XX(11)/.12500000000000000000D+00/ DATA XX(12)/.68750000000000000000D+00/ DATA XX(13)/.81250000000000000000D+00/ DATA XX(14)/.98437500000000000000D+00/ DATA XX(15)/.18750000000000000000D+00/ DATA XX(16)/.31250000000000000000D+00/ DATA XX(17)/.43750000000000000000D+00/ DATA XX(18)/.56250000000000000000D+00/ DATA XX(19)/.84375000000000000000D+00/ DATA XX(20)/.90625000000000000000D+00/ DATA XX(21)/.99218750000000000000D+00/ C NUMBER OF NODES 13 DATA WW(1)/1.303262173284849021810473057638590518409112513421D-1/ DATA WW(2)/2.390632866847646220320329836544615917290026806242D-1/ DATA WW(3)/2.630626354774670227333506083741355715758124943143D-1/ DATA WW(4)/2.186819313830574175167853094864355208948886875898D-1/ DATA WW(5)/2.757897646642836865859601197607471574336674206700D-2/ DATA WW(6)/1.055750100538458443365034879086669791305550493830D-1/ DATA WW(7)/1.571194260595182254168429283636656908546309467968D-2/ C NUMBER OF NODES 19 DATA WW(8)/1.298751627936015783241173611320651866834051160074D-1/ DATA WW(9)/2.249996826462523640447834514709508786970828213187D-1/ DATA WW(15)/5.542699233295875168406783695143646338274805359780D-2/ DATA WW(10)/1.680415725925575286319046726692683040162290325505D-1/ DATA WW(16)/9.986735247403367525720377847755415293097913496236D-2/ DATA WW(11)/1.415567675701225879892811622832845252125600939627D-1/ DATA WW(12)/1.006482260551160175038684459742336605269707889822D-1/ DATA WW(13)/2.510604860724282479058338820428989444699235030871D-2/ DATA WW(17)/4.507523056810492466415880450799432587809828791196D-2/ DATA WW(14)/9.402964360009747110031098328922608224934320397592D-3/ C NUMBER OF NODES 27 DATA WW(18)/6.300942249647773931746170540321811473310938661469D-2/ DATA WW(28)/1.239572396231834242194189674243818619042280816640D-1/ DATA WW(19)/1.261383225537664703012999637242003647020326905948D-1/ DATA WW(25)/1.235837891364555000245004813294817451524633100256D-1/ DATA WW(20)/1.273864433581028272878709981850307363453523117880D-1/ DATA WW(26)/1.148933497158144016800199601785309838604146040215D-1/ DATA WW(29)/2.501306413750310579525950767549691151739047969345D-2/ DATA WW(21)/8.576500414311820514214087864326799153427368592787D-2/ DATA WW(30)/4.915957918146130094258849161350510503556792927578D-2/ DATA WW(22)/7.102884842310253397447305465997026228407227220665D-2/ DATA WW(23)/5.026383572857942403759829860675892897279675661654D-2/ DATA WW(27)/1.252575774226122633391477702593585307254527198070D-2/ DATA WW(31)/2.259167374956474713302030584548274729936249753832D-2/ DATA WW(24)/4.683670010609093810432609684738393586390722052124D-3/ C NUMBER OF NODES 41 DATA WW(32)/6.362762978782724559269342300509058175967124446839D-2/ DATA WW(42)/1.187141856692283347609436153545356484256869129472D-1/ DATA WW(46)/1.533126874056586959338368742803997744815413565014D-2/ DATA WW(33)/9.950065827346794643193261975720606296171462239514D-2/ DATA WW(47)/3.527159369750123100455704702965541866345781113903D-2/ DATA WW(39)/8.140326425945938045967829319725797511040878579808D-2/ DATA WW(48)/5.000556431653955124212795201196389006184693561679D-2/ DATA WW(34)/7.048220002718565366098742295389607994441704889441D-2/ DATA WW(49)/5.744164831179720106340717579281831675999717767532D-2/ DATA WW(40)/6.583213447600552906273539578430361199084485578379D-2/ DATA WW(43)/5.999947605385971985589674757013565610751028128731D-2/ DATA WW(35)/6.512297339398335645872697307762912795346716454337D-2/ DATA WW(44)/5.500937980198041736910257988346101839062581489820D-2/ DATA WW(50)/1.598823797283813438301248206397233634639162043386D-2/ DATA WW(36)/3.998229150313659724790527138690215186863915308702D-2/ DATA WW(51)/2.635660410220884993472478832884065450876913559421D-2/ DATA WW(37)/3.456512257080287509832054272964315588028252136044D-2/ DATA WW(41)/2.592913726450792546064232192976262988065252032902D-2/ DATA WW(45)/5.264422421764655969760271538981443718440340270116D-3/ DATA WW(52)/1.196003937945541091670106760660561117114584656319D-2/ DATA WW(38)/2.212167975884114432760321569298651047876071264944D-3/ C------------------------ K = KE + 1 IS = ISTART(K) KS = LEN(K) LDL = XU - XL BB = LDL*0.5D0 AA = XL + BB C Y = 0.D0 DO 10 I = 1,KS C = BB*XX(I) IF (I .GT. L1) FV1(I) = F(AA + C) IF (I .GT. L2) FV2(I) = F(AA - C) J = IS + I Y = Y + (FV1(I) + FV2(I))*WW(J) 10 CONTINUE C Y2 = Y Y = Y*BB IF (L1 .LT. KS) L1 = KS IF (L2 .LT. KS) L2 = KS IF (KE .NE. K1) RETURN C YA = 0.D0 DO 20 I = 1,KS J = IS + I YA = YA + (DABS(FV1(I)) + DABS(FV2(I)))*WW(J) 20 CONTINUE YA = YA*DABS(BB) C Y2 = Y2*0.5D0 YM = 0.D0 DO 30 I = 1,KS J = IS + I YM = YM + (DABS(FV1(I) - Y2) + DABS(FV2(I) - Y2))*WW(J) 30 CONTINUE YM = YM*DABS(BB) RETURN END SUBROUTINE DQXRRD (F,Z,LZ,XL,XU,R,S,LR,LS) C C TO REORDER THE COMPUTED FUNCTIONAL VALUES BEFORE C THE BISECTION OF AN INTERVAL C C PARAMETERS C ON ENTRY C F - DOUBLE PRECISION C FUNCTION SUBPROGRAM DEFINING THE INTEGRAND C FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE C DECLARED E X T E R N A L IN THE DRIVER PROGRAM. C C XL - DOUBLE PRECISION C LOWER LIMIT OF INTERVAL C C XU - DOUBLE PRECISION C UPPER LIMIT OF INTERVAL C C Z - DOUBLE PRECISION C VECTOR CONTAINING LZ C SAVED FUNCTIONAL VALUES C C LZ - INTEGER C NUMBER OF ELEMENTS IN LZ C C ON RETURN C R - DOUBLE PRECISION C S VECTORS CONTAINING LR, LS C SAVED FUNCTIONAL VALUES FOR THE NEW INTERVALS C C LR - INTEGER C LS NUMBER OF ELEMENTES IN R,S RESPECTIVELY C C***ROUTINES CALLED F C DOUBLE PRECISION F,R,S,Z,XU,XL,DLEN,CENTR INTEGER LR,LS,LZ DIMENSION R(21),S(21),Z(21) C DLEN = (XU - XL)*0.5D0 CENTR = XL + DLEN R(1) = Z(3) R(2) = Z(9) R(3) = Z(4) R(4) = Z(5) R(5) = Z(6) R(6) = Z(10) R(7) = Z(7) S(1) = Z(3) S(2) = Z(8) S(3) = Z(2) S(7) = Z(1) IF (LZ .GT. 11) GO TO 10 C R(8) = F(CENTR + DLEN*0.375D0) R(9) = F(CENTR + DLEN*0.625D0) R(10) = F(CENTR + DLEN*0.96875D0) LR = 10 IF (LZ .NE. 11) S(4) = F(CENTR - DLEN*0.75D0) IF (LZ .EQ. 11) S(4) = Z(11) S(5) = F(CENTR - DLEN*0.875D0) S(6) = F(CENTR - DLEN*0.9375D0) S(8) = F(CENTR - DLEN*0.375D0) S(9) = F(CENTR - DLEN*0.625D0) S(10) = F(CENTR - DLEN*0.96875D0) LS = 10 RETURN C 10 R(8) = Z(12) R(9) = Z(13) R(10) = Z(14) LR = 10 S(4) = Z(11) S(5) = F(CENTR - DLEN*0.875D0) S(6) = F(CENTR - DLEN*0.9375D0) IF (LZ .GT. 14) GO TO 20 S(8) = F(CENTR - DLEN*0.375D0) S(9) = F(CENTR - DLEN*0.625D0) S(10) = F(CENTR - DLEN*0.96875D0) LS = 10 RETURN C 20 R(11) = Z(18) R(12) = Z(19) R(13) = Z(20) R(14) = Z(21) LR = 14 S(8) = Z(16) S(9) = Z(15) S(10) = F(CENTR - DLEN*0.96875D0) S(11) = Z(17) LS = 11 RETURN END SUBROUTINE CUBTRI(F, T, EPS, MCALLS, ANS, ERR, NCALLS, W, NW, * IDATA, RDATA, IER) C C ADAPTIVE CUBATURE OVER A TRIANGLE C C PARAMETERS C F - USER SUPPLIED EXTERNAL FUNCTION OF THE FORM C F(X,Y,IDATA,RDATA) C WHERE X AND Y ARE THE CARTESIAN COORDINATES OF A C POINT IN THE PLANE, AND IDATA AND RDATA ARE INTEGER C AND REAL VECTORS IN WHICH DATA MAY BE PASSED. C T - ARRAY OF DIMENSION (2,3) WHERE T(1,J) AND T(2,J) C ARE THE X AND Y COORDINATES OF THE J-TH VERTEX OF C THE GIVEN TRIANGLE (INPUT) C EPS - REQUIRED TOLERANCE (INPUT). IF THE COMPUTED C INTEGRAL IS BETWEEN-1 AND 1, AN ABSOLUTE ERROR C TEST IS USED, ELSE A RELATIVE ERROR TEST IS USED. C MCALLS- MAXIMUM PERMITTED NUMBER OF CALLS TO F (INPUT) C ANS - ESTIMATE FOR THE VALUE OF THE INTEGRAL OF F OVER C THE GIVEN TRIANGLE (OUTPUT) C ERR - ESTIMATED ABSOLUTE ERROR IN ANS (OUTPUT) C NCALLS- ACTUAL NUMBER OF CALLS TO F (OUTPUT). THIS C PARAMETER MUST BE INITIALIZED TO 0 ON THE FIRST C CALL TO CUBTRI FOR A GIVEN INTEGRAL (INPUT) C W - WORK SPACE. MAY NOT BE DESTROYED BETWEEN CALLS TO C CUBTRI IF RESTARTING IS INTENDED C NW - LENGTH OF WORK SPACE (INPUT). C IF NW .GE. 3*(19+3*MCALLS)/38, TERMINATION DUE TO C FULL WORK SPACE WILL NOT OCCUR. C IER - TERMINATION INDICATOR (OUTPUT) C IER=0 NORMAL TERMINATION, TOLERANCE SATISFIED C IER=1 MAXIMUM NUMBER OF CALLS REACHED C IER=2 WORK SPACE FULL C IER=3 FURTHER SUBDIVISION OF TRIANGLES IMPOSSIBLE C IER=4 NO FURTHER IMPROVEMENT IN ACCURACY IS C POSSIBLE DUE TO ROUNDING ERRORS IN FUNCTION C VALUES C IER=5 NO FURTHER IMPROVEMENT IN ACCURACY IS C POSSIBLE BECAUSE SUBDIVISION DOES NOT C CHANGE THE ESTIMATED INTEGRAL. MACHINE C ACCURACY HAS PROBABLY BEEN REACHED BUT C THE ERROR ESTIMATE IS NOT SHARP ENOUGH. C C CUBTRI IS DESIGNED TO BE CALLED REPEATEDLY WITHOUT WASTING C EARLIER WORK. THE PARAMETER NCALLS IS USED TO INDICATE TO C CUBTRI AT WHAT POINT TO RESTART, AND MUST BE RE-INITIALIZED C TO 0 WHEN A NEW INTEGRAL IS TO BE COMPUTED. AT LEAST ONE OF C THE PARAMETERS EPS, MCALLS AND NW MUST BE CHANGED BETWEEN C CALLS TO CUBTRI, ACCORDING TO THE RETURNED VALUE OF IER. NONE C OF THE OTHER PARAMETERS MAY BE CHANGED IF RESTARTING IS DONE. C IF IER=3 IS ENCOUNTERED, THERE PROBABLY IS A SINGULARITY C SOMEWHERE IN THE REGION. THE ERROR MESSAGE INDICATES THAT C FURTHER SUBDIVISION IS IMPOSSIBLE BECAUSE THE VERTICES OF THE C SMALLER TRIANGLES PRODUCED WILL BEGIN TO COALESCE TO THE C PRECISION OF THE COMPUTER. THIS SITUATION CAN USUALLY BE C RELIEVED BY SPECIFYING THE REGION IN SUCH A WAY THAT THE C SINGULARITY IS LOCATED AT THE THIRD VERTEX OF THE TRIANGLE. C IF IER=4 IS ENCOUNTERED, THE VALUE OF THE INTEGRAL CANNOT BE C IMPROVED ANY FURTHER. THE ONLY EXCEPTION TO THIS OCCURS WHEN A C FUNCTION WITH HIGHLY IRREGULAR BEHAVIOUR IS INTEGRATED (E.G. C FUNCTIONS WITH JUMP DISCONTINUITIES OR VERY HIGHLY OSCILLATORY C FUNCTIONS). IN SUCH A CASE THE USER CAN DISABLE THE ROUNDING C ERROR TEST BY REMOVING THE IF STATEMENT IMMEDIATELY PRECEDING C STATEMENT NUMBER 90. C EXTERNAL F INTEGER IDATA(*), IER, MCALLS, NCALLS, NW REAL ALFA, ANS, ANSKP, AREA, EPS, ERR, ERRMAX, H, Q1, Q2, R1, R2, * RDATA(*), D(2,4), S(4), T(2,*), VEC(2,3), W(6,NW), X(2) C ACTUAL DIMENSION OF W IS (6,NW/6) C DOUBLE PRECISION TANS, TERR, DZERO COMMON /CUBSTA/ TANS, TERR C THIS COMMON IS REQUIRED TO PRESERVE TANS AND TERR BETWEEN CALLS C AND TO SAVE VARIABLES IN FUNCTION RNDERR DATA NFE /19/, S(1), S(2), S(3), S(4) /3*1E0,-1E0/, D(1,1), * D(2,1) /0.0,0.0/, D(1,2), D(2,2) /0.0,1.0/, D(1,3), D(2,3) * /1.0,0.0/, D(1,4), D(2,4) /1.0,1.0/ C NFE IS THE NUMBER OF FUNCTION EVALUATIONS PER CALL TO CUBRUL. DATA ZERO /0.E0/, ONE /1.E0/, DZERO /0.D0/, POINT5 /.5E0/ C C CALCULATE DIRECTION VECTORS, AREA AND MAXIMUM NUMBER C OF SUBDIVISIONS THAT MAY BE PERFORMED DO 20 I=1,2 VEC(I,3) = T(I,3) DO 10 J=1,2 VEC(I,J) = T(I,J) - T(I,3) 10 CONTINUE 20 CONTINUE MAXC = (MCALLS/NFE+3)/4 IER = 1 MAXK = MIN0(MAXC,(NW/6+2)/3) IF (MAXC.GT.MAXK) IER = 2 AREA = ABS(VEC(1,1)*VEC(2,2)-VEC(1,2)*VEC(2,1))*POINT5 K = (NCALLS/NFE+3)/4 MW = 3*(K-1) + 1 IF (NCALLS.GT.0) GO TO 30 C C TEST FOR TRIVIAL CASES TANS = DZERO TERR = DZERO IF (AREA.EQ.ZERO) GO TO 90 IF (MCALLS.LT.NFE) GO TO 100 IF (NW.LT.6) GO TO 110 C C INITIALIZE DATA LIST K = 1 MW = 1 W(1,1) = ZERO W(2,1) = ZERO W(3,1) = ONE CALL CUBRUL(F, VEC, W(1,1), IDATA, RDATA) TANS = W(5,1) TERR = W(6,1) NCALLS = NFE C C TEST TERMINATION CRITERIA 30 ANS = TANS ERR = TERR IF (ERR.LT.AMAX1(ONE,ABS(ANS))*EPS) GO TO 90 IF (K.EQ.MAXK) GO TO 120 C C FIND TRIANGLE WITH LARGEST ERROR ERRMAX = ZERO DO 40 I=1,MW IF (W(6,I).LE.ERRMAX) GO TO 40 ERRMAX = W(6,I) J = I 40 CONTINUE C C SUBDIVIDE TRIANGLE INTO FOUR SUBTRIANGLES AND UPDATE DATA LIST DO 50 I=1,2 X(I) = W(I,J) 50 CONTINUE H = W(3,J)*POINT5 IF (RNDERR(X(1),H,X(1),H).NE.ZERO) GO TO 130 IF (RNDERR(X(2),H,X(2),H).NE.ZERO) GO TO 130 ANSKP = SNGL(TANS) TANS = TANS - DBLE(W(5,J)) TERR = TERR - DBLE(W(6,J)) R1 = W(4,J) R2 = W(5,J) JKP = J Q1 = ZERO Q2 = ZERO DO 70 I=1,4 DO 60 L=1,2 W(L,J) = X(L) + H*D(L,I) 60 CONTINUE W(3,J) = H*S(I) CALL CUBRUL(F, VEC, W(1,J), IDATA, RDATA) Q2 = Q2 + W(5,J) Q1 = Q1 + W(4,J) J = MW + I 70 CONTINUE ALFA = 1E15 IF (Q2.NE.R2) ALFA = ABS((Q1-R1)/(Q2-R2)-ONE) J = JKP DO 80 I=1,4 W(6,J) = W(6,J)/ALFA TANS = TANS + W(5,J) TERR = TERR + W(6,J) J = MW + I 80 CONTINUE MW = MW + 3 NCALLS = NCALLS + 4*NFE K = K + 1 C C IF ANSWER IS UNCHANGED, IT CANNOT BE IMPROVED IF (ANSKP.EQ.SNGL(TANS)) GO TO 150 C C REMOVE THIS IF STATEMENT TO DISABLE ROUNDING ERROR TEST IF (K.GT.3 .AND. ABS(Q2-R2).GT.ABS(Q1-R1)) GO TO 140 GO TO 30 C C EXITS FROM SUBROUTINE 90 IER = 0 GO TO 120 100 IER = 1 GO TO 120 110 IER = 2 120 ANS = TANS ERR = TERR RETURN 130 IER = 3 GO TO 120 140 IER = 4 GO TO 120 150 IER = 5 GO TO 120 END FUNCTION RNDERR(X, A, Y, B) C THIS FUNCTION COMPUTES THE ROUNDING ERROR COMMITTED WHEN THE C SUM X+A IS FORMED. IN THE CALLING PROGRAM, Y MUST BE THE SAME C AS X AND B MUST BE THE SAME AS A. THEY ARE DECLARED AS C DISTINCT VARIABLES IN THIS FUNCTION, AND THE INTERMEDIATE C VARIABLES S AND T ARE PUT INTO COMMON, IN ORDER TO DEFEND C AGAINST THE WELL-MEANING ACTIONS OF SOME OFFICIOUS OPTIMIZING C FORTRAN COMPILERS. COMMON /CUBATB/ S, T S = X + A T = S - Y RNDERR = T - B RETURN END SUBROUTINE CUBRUL(F, VEC, P, IDATA, RDATA) C C BASIC CUBATURE RULE PAIR OVER A TRIANGLE C C PARAMETERS C F - EXTERNAL FUNCTION - SEE COMMENTS TO CUBTRI C VEC- MATRIX OF BASE VECTORS AND ORIGIN (INPUT) C P - TRIANGLE DESCRIPTION VECTOR OF DIMENSION 6 C P(1) - TRANSFORMED X COORDINATE OF ORIGIN VERTEX(INPUT) C P(2) - TRANSFORMED Y COORDINATE OF ORIGIN VERTEX(INPUT) C P(3) - DISTANCE OF OTHER VERTICES IN THE DIRECTIONS C OF THE BASE VECTORS (INPUT) C P(4) - LESS ACCURATE ESTIMATED INTEGRAL (OUTPUT) C P(5) - MORE ACCURATE ESTIMATED INTEGRAL (OUTPUT) C P(6) - ABS(P(5)-P(4)) (OUTPUT) C C CUBRUL EVALUATES A LINEAR COMBINATION OF BASIC INTEGRATION C RULES HAVING D3 SYMMETRY. THE AREAL COORDINATES PERTAINING TO C THE J-TH RULE ARE STORED IN W(I,J),I=1,2,3. THE CORRESPONDING C WEIGHTS ARE W(4,J) AND W(5,J), WITH W(5,J) BELONGING TO THE C MORE ACCURATE FORMULA. IF W(1,J).EQ.W(2,J), THE INTEGRATION C POINT IS THE CENTROID, ELSE IF W(2,J).EQ.W(3,J), THE EVALUATION C POINTS ARE ON THE MEDIANS. IN BOTH CASES ADVANTAGE IS TAKEN OF C SYMMETRY TO AVOID REPEATING FUNCTION EVALUATIONS. C C THE FOLLOWING DOUBLE PRECISION VARIABLES ARE USED TO AVOID C UNNECESSARY ROUNDING ERRORS IN FLOATING POINT ADDITION. C THEY MAY BE DECLARED SINGLE PRECISION IF DOUBLE PRECISION IS C NOT AVAILABLE AND FULL ACCURACY IS NOT NEEDED. C DOUBLE PRECISION A1, A2, S, SN, DZERO, DONE, DTHREE, DSIX REAL AREA, ORIGIN(2), P(*), RDATA(*), TVEC(2,3), VEC(2,*), W(5,6) INTEGER IDATA(*) EXTERNAL F C C W CONTAINS POINTS AND WEIGHTS OF THE INTEGRATION FORMULAE C NQUAD - NUMBER OF BASIC RULES USED C C THIS PARTICULAR RULE IS THE 19 POINT EXTENSION (DEGREE 8) OF C THE FAMILIAR 7 POINT RULE (DEGREE 5). C C SIGMA=SQRT(7) C PHI=SQRT(15) C W(1,1),W(2,1),W(3,1) = 1/3 C W(4,1) = 9/40 C W(5,1) = 7137/62720 - 45*SIGMA/1568 C W(1,2) = 3/7 + 2*PHI/21 C W(2,2),W(3,2) = 2/7 - PHI/21 C W(4,2) = 31/80 - PHI/400 C W(5,2) = - 9301697/4695040 - 13517313*PHI/23475200 C + 764885*SIGMA/939008 + 198763*PHI*SIGMA/939008 C W(*,3) = W(*,2) WITH PHI REPLACED BY -PHI C W(1,5) = 4/9 + PHI/9 + SIGMA/9 - SIGMA*PHI/45 C W(2,5),W(3,5) = 5/18 - PHI/18 - SIGMA/18 + SIGMA*PHI/90 C W(4,5) = 0 C W(5,5) = 102791225/59157504 + 23876225*PHI/59157504 C - 34500875*SIGMA/59157504 - 9914825*PHI*SIGMA/59157504 C W(*,4) = W(*,5) WITH PHI REPLACED BY -PHI C W(1,6) = 4/9 + SIGMA/9 C W(2,6) = W(2,4) C W(3,6) = W(2,5) C W(4,6) = 0 C W(5,6) = 11075/8064 - 125*SIGMA/288 C DATA NQUAD /6/ DATA W(1,1), W(2,1), W(3,1) /3*.3333333333333333333333333E0/, * W(4,1), W(5,1) /.225E0,.3786109120031468330830822E-1/, * W(1,2), W(2,2), W(3,2) /.7974269853530873223980253E0,2* * .1012865073234563388009874E0/, W(4,2), W(5,2) * /.3778175416344814577870518E0,.1128612762395489164329420E0/, * W(1,3), W(2,3), W(3,3) /.5971587178976982045911758E-1,2* * .4701420641051150897704412E0/, W(4,3), W(5,3) * /.3971824583655185422129482E0,.2350720567323520126663380E0/ DATA W(1,4), W(2,4), W(3,4) /.5357953464498992646629509E0,2* * .2321023267750503676685246E0/, W(4,4), W(5,4) * /0.E0,.3488144389708976891842461E0/, W(1,5), W(2,5), W(3,5) * /.9410382782311208665596304E0,2*.2948086088443956672018481E-1/, * W(4,5), W(5,5) /0.E0,.4033280212549620569433320E-1/, W(1,6), * W(2,6), W(3,6) /.7384168123405100656112906E0, * .2321023267750503676685246E0,.2948086088443956672018481E-1/, * W(4,6), W(5,6) /0.E0,.2250583347313904927138324E0/ C DATA DZERO /0.D0/, DONE /1.D0/, DTHREE /3.D0/, DSIX /6.D0/, * POINT5 /.5E0/ C C SCALE BASE VECTORS AND OBTAIN AREA C DO 20 I=1,2 ORIGIN(I) = VEC(I,3) + P(1)*VEC(I,1) + P(2)*VEC(I,2) DO 10 J=1,2 TVEC(I,J) = P(3)*VEC(I,J) 10 CONTINUE 20 CONTINUE AREA = POINT5*ABS(TVEC(1,1)*TVEC(2,2)-TVEC(1,2)*TVEC(2,1)) A1 = DZERO A2 = DZERO C C COMPUTE ESTIMATES FOR INTEGRAL AND ERROR C DO 40 K=1,NQUAD X = ORIGIN(1) + W(1,K)*TVEC(1,1) + W(2,K)*TVEC(1,2) Y = ORIGIN(2) + W(1,K)*TVEC(2,1) + W(2,K)*TVEC(2,2) S = DBLE(F(X,Y,IDATA,RDATA)) SN = DONE IF (W(1,K).EQ.W(2,K)) GO TO 30 X = ORIGIN(1) + W(2,K)*TVEC(1,1) + W(1,K)*TVEC(1,2) Y = ORIGIN(2) + W(2,K)*TVEC(2,1) + W(1,K)*TVEC(2,2) S = S + DBLE(F(X,Y,IDATA,RDATA)) X = ORIGIN(1) + W(2,K)*TVEC(1,1) + W(3,K)*TVEC(1,2) Y = ORIGIN(2) + W(2,K)*TVEC(2,1) + W(3,K)*TVEC(2,2) S = S + DBLE(F(X,Y,IDATA,RDATA)) SN = DTHREE IF (W(2,K).EQ.W(3,K)) GO TO 30 X = ORIGIN(1) + W(1,K)*TVEC(1,1) + W(3,K)*TVEC(1,2) Y = ORIGIN(2) + W(1,K)*TVEC(2,1) + W(3,K)*TVEC(2,2) S = S + DBLE(F(X,Y,IDATA,RDATA)) X = ORIGIN(1) + W(3,K)*TVEC(1,1) + W(1,K)*TVEC(1,2) Y = ORIGIN(2) + W(3,K)*TVEC(2,1) + W(1,K)*TVEC(2,2) S = S + DBLE(F(X,Y,IDATA,RDATA)) X = ORIGIN(1) + W(3,K)*TVEC(1,1) + W(2,K)*TVEC(1,2) Y = ORIGIN(2) + W(3,K)*TVEC(2,1) + W(2,K)*TVEC(2,2) S = S + DBLE(F(X,Y,IDATA,RDATA)) SN = DSIX 30 S = S/SN A1 = A1 + W(4,K)*S A2 = A2 + W(5,K)*S 40 CONTINUE P(4) = SNGL(A1)*AREA P(5) = SNGL(A2)*AREA P(6) = ABS(P(5)-P(4)) RETURN END SUBROUTINE IESLV (KERNEL,RHFCN,A,B,EP,IFLAG,T,X,NT,NUPPER, * MUPPER,NF,MF,NORM,W,IER) C C THE INTEGRAL EQUATION BEING SOLVED IS C C B C X(S) - INT KERNEL(S,T)*X(T)*DT = RHFCN(S) C A C C THE METHOD BEING USED IS BASED ON THE NYSTROM METHOD WITH C GAUSSIAN QUADRATURE, WITH AN ITERATIVE TECHNIQUE OF SOLUTION C FOR THE RESULTING LINEAR SYSTEM. C C KERNEL THESE ARE REAL FUNCTIONS OF TWO AND ONE C RHFCN VARIABLES, RESPECTIVELY. THEY MUST BE DECLARED IN AN C EXTERNAL STATEMENT IN THE PROGRAM CALLING IESLV. C EP THE DESIRED ERROR. THE VARIABLE EP IS CHANGED ON C COMPLETION OF THE PROGRAM. SEE THE DISCUSSION OF IER C AND IFLAG FOR MORE INFORMATION. C IFLAG =0 EP IS INTERPRETED AS AN ABSOLUTE ERROR TOLERANCE. C =1 EP IS INTERPRETED AS A RELATIVE ERROR TOLERANCE. C T CONTAINS THE NODE POINTS AT WHICH THE SOLUTION OF THE C INTEGRAL EQUATION IS DESIRED. SEE THE VARIABLE NT FOR C MORE INFORMATION. C X THE COMPUTED APPROXIMATE SOLUTION OF THE INTEGRAL C EQUATION, EVALUATED AT THE NODE POINTS IN T, IS C STORED IN X ON COMPLETION OF THE ROUTINE. THIS IS C TRUE IRREGARDLESS OF WHETHER OR NOT THE DESIRED ERROR C TOLERANCE WAS ATTAINED. C NT IF NT=0, THEN T AND X WILL BE SET EQUAL TO THE FINAL C GAUSSIAN NODES AND THE CORRESPONDING SOLUTION VALUES, C AND NT WILL BE SET TO THE NUMBER OF THE SOLUTION C VALUES STORED IN X AND T. THE ARRAYS T AND X SHOULD C HAVE DIMENSION AT LEAST MUPPER, ASSIGNED IN THE C CALLING PROGRAM. C IF NT .GT. 0, THEN T CONTAINS NT USER SUPPLIED NODES C AT WHICH THE SOLUTION X IS DESIRED. C NUPPER AN UPPER LIMIT ON THE VARIABLE N IN THIS PROGRAM. C N IS THE ORDER OF A LINEAR SYSTEM WHICH IS BEING C USED TO ITERATIVELY SOLVE A LARGER LINEAR SYSTEM OF C ORDER M WHICH APPROXIMATES THE INTEGRAL EQUATION. C (FOR FURTHER DETAILS CONCERNING THE MAXIMUM VALUE C THAT N CAN TAKE, SEE THE DESCRIPTION OF NMAX BELOW.) C MUPPER AN UPPER LIMIT ON THE VARIABLE M IN THE PROGRAM. C N AND M ARE ALWAYS POWERS OF TWO. C NF SAME AS NFINAL (SEE BELOW) C MF SAME AS MFINAL (SEE BELOW) C NORM SAME AS NORMK (SEE BELOW) C W TEMPORARY WORKING STORAGE FOR THE PROGRAM. IT MUST C CONTAIN AT LEAST 5*NU*NU+9*(NU+MU) POSITIONS, WITH C NU=NUPPER, MU=MUPPER. C IER =0 THIS ERROR COMPLETION CODE MEANS THE ROUTINE WAS C COMPLETED SATISFACTORILY. EP CONTAINS THE PREDICTED C ERROR. C =1 THE ERROR TEST WAS NOT SATISFIED. EP CONTAINS THE C PREDICTED ERROR. C =2 THE ERROR TEST WAS NOT SATISFIED. EP HAS BEEN SET C TO ZERO. C =3 THE ORIGINAL VALUE OF EP WAS TOO SMALL, DUE TO C POSSIBLE ILL-CONDITIONING PROBLEMS IN THE INTEGRAL C EQUATION. THE VALUE OF EP WAS RESET TO A MORE C REALISTIC VALUE, AND THAT TOLERANCE WAS ATTAINED. C =4 THE ERROR WAS SATISFACTORY AT THE GAUSSIAN NODE C POINTS (IER=0), BUT THE INTERPOLATION PROCESS(DUE TO C NT .GT. 0) MAY NOT PRESERVE THIS ACCURACY. CHECK THE C VALUE OF NORM(K) FOR POSSIBLE INDICATIONS THAT THE C INTEGRAL EQUATION MAY BE ALMOST FIRST KIND. SUCH C EQUATIONS ARE QUITE ILL-CONDITIONED. THE ERROR IN EP C IS THE PREDICTED ERROR FOR THE SOLUTION AT THE C GAUSSIAN NODE POINTS OF ORDER MFINAL. C =5 THE ANALOGUE OF IER=4, BUT WITH IER=1 AT THE C GAUSSIAN NODE POINTS. C =6 THE ANALOGUE OF IER=4, BUT WITH IER=3 AT THE C GAUSSIAN NODE POINTS. C C C *** REFERENCES *** C (1) AN AUTOMATIC PROGRAM FOR FREDHOLM INTEGRAL EQUATIONS OF THE C SECOND KIND, ACM TRANS. MATH SOFTWARE 2(1976), PP.154-171. C (2) A SURVEY OF NUMERICAL METHODS FOR THE SOLUTION OF FREDHOLM C INTEGRAL EQUATIONS OF THE SECOND KIND, SIAM PUB., 1976, C PART II, CHAP. 5. C REAL KERNEL,NORM,NORMK DIMENSION X(*),T(*),W(*) EXTERNAL KERNEL,RHFCN C C******************************************************************* C * COMMON/XXINFO/R1,R2,FINLEP,NORMK,NFINAL,MFINAL C * C THE NUMBERS IN XXINFO GIVE ADDITIONAL INFORMATION ABOUT THE * C FUNCTIONING OF IESLV. R1 IS THE ITERATIVE RATE OF CONVERGENCE * C IN THE MOST RECENTLY COMPUTED LINEAR SYSTEM. R2 IS THE RATE OF * C CONVERGENCE OF THE GAUSSIAN QUADRATURE VARIANT OF THE NYSTROM * C METHOD. FINLEP IS THE FINAL VALUE OF EP USED AS THE DESIRED * C ERROR TOLERANCE. USUALLY FINLEP WILL EQUAL THE INPUT VALUE OF * C EP, UNLESS EP WAS MUCH TOO SMALL. NORMK IS AN APPROXIMATE * C VALUE FOR THE NORM OF THE INTEGRAL OPERATOR K, AND IT IS * C CALCULATED ONLY IF NT .GT. 0. * C NFINAL AND MFINAL ARE THE FINAL VALUES OF N AND M USED IN * C IESLV. IF NFINAL=MFINAL, THEN ITERATION WAS NOT INVOKED * C SUCCESSFULLY. * C * C******************************************************************* C * C NMAX IS THE MAXIMUM VALUE FOR N THAT IS PERMITTED BY IESLV. * C THUS MIN0(NUPPER,NMAX) IS THE MAXIMUM VALUE FOR N THAT CAN BE * C USED. THERE IS ALSO AN UPPER LIMIT OF 128 ON N IMPOSED BY THE * C SUBROUTINE LNSYS. * C * DATA NMAX /64/ C * C******************************************************************* C * C UNITRD IS A MACHINE DEPENDENT PARAMETER. ASSIGN UNITRD THE * C VALUE U WHERE U IS THE SMALLEST FLOATING POINT NUMBER SUCH * C THAT 1.0 + U .GT. 1.0. * C * UNITRD = SPMPAR(1) C * C******************************************************************* C CUTOFF = 0.5 ROOTRT = 0.1 NUP = MIN0(NUPPER,NMAX) C C SET UP THE RELATIVE BASE ADDRESSES FOR THE VARIOUS ARRAYS INTO C WHICH W IS TO BE SPLIT. N=NUP M=MUPPER NSQ=N*N I1=1 I2=I1+NSQ I3=I2+NSQ I4=I3+NSQ/2 I5=I4+NSQ/2 I6=I5+M I7=I6+M I8=I7+N I9=I8+N I10=I9+M I11=I10+N I12=I11+M I13=I12+M I14=I13+M I15=I14+N I16=I15+M I17=I16+M I18=I17+N I19=I18+M I20=I19+4*N I21=I20+NSQ NHALF=N/2 CALL IEGS(KERNEL,RHFCN,A,B,EP,IFLAG,X,T,NT,NUP,MUPPER,IER, * CUTOFF,ROOTRT,UNITRD,NHALF,W(I1),W(I2),W(I3),W(I4),W(I5), * W(I6),W(I7),W(I8),W(I9),W(I10),W(I11),W(I12),W(I13), * W(I14),W(I15),W(I16),W(I17),W(I18),W(I19),W(I20),W(I21)) NORM=NORMK NF=NFINAL MF=MFINAL RETURN END SUBROUTINE IEGS(KERNEL,RHFCN,A,B,EP,IFLAG,X,T,NT,NUP,MUP,IER, * CUTOFF,ROOTRT,UNITRD,NHALF,LUFACT,KMM,KMN,KNM,RHS,R,RH, * DELN,TM,TN,XM,XMZ,WM,WN,OLDX,SAVE,XN,SAVE2,ASIDE,ASIDE3, * IMKNN) C C THIS ROUTINE CONTROLS THE SOLUTION OF THE INTEGRAL EQUATION. C REAL KERNEL,LUFACT,KMM,KMN,KNM,IMKNN,NORMK,NUMR1,NUMR2 INTEGER FLAG,OLDM,PIVOT(128) DIMENSION X(*),T(*),LUFACT(NUP,NUP),KMM(NUP,NUP),RHS(MUP), * KNM(NHALF,NUP),KMN(NUP,NHALF),R(MUP),RH(NUP),DELN(NUP), * TM(MUP),TN(NUP),XM(MUP),XMZ(MUP),WM(MUP),WN(NUP),OLDX(MUP), * SAVE(MUP),XN(NUP),SAVE2(MUP),ASIDE(NUP,*),ASIDE2(5), * ASIDE3(NUP,NUP),IMKNN(NUP,NUP) COMMON/XXLIN/ELINSY,RELRSD,PIVOT COMMON/XXINFO/R1,R2,FINLEP,NORMK,NFINAL,MFINAL EXTERNAL KERNEL,RHFCN C C INITIALIZATION C LOOP=1 N=2 R2=0.5 M=2*N R1RAT=ROOTRT COND=1.0 PASTC=1.0 PASTRE=0.0 EPS=EP C C STAGE A. DIRECT SOLUTION OF LINEAR SYSTEM (I-KN)*XN=RHS, WHILE C TRYING TO FIND A GOOD APPROXIMATE INVERSE TO IMPLEMENT C ITERATIVE METHOD OF SOLUTION. C C CREATE THE NODES AND WEIGHTS TN(I) AND WN(I), I=1,...,N CALL WANDT(WN,TN,N,A,B) C SET UP MATRIX FOR (I-KN)*XN=RHFCN DO 2 J=1,N DO 1 I=1,N 1 IMKNN(I,J)=-WN(J)*KERNEL(TN(I),TN(J)) XMZ(J)=RHFCN(TN(J)) 2 IMKNN(J,J)=IMKNN(J,J)+1.0 GO TO 6 C THIS IS ENTRANCE FOR AN INCREASED VALUE OF N, USING PREVIOUSLY C STORED VALUES IN KMM TO DEFINE MATRIX FOR (I-KN)*XN=RHFCN WITH C NEW VALUE OF N. 3 DO 5 J=1,N DO 4 I=1,N 4 IMKNN(I,J)=-KMM(I,J) WN(J)=WM(J) TN(J)=TM(J) XMZ(J)=RHS(J) 5 IMKNN(J,J)=IMKNN(J,J)+1.0 C THIS IS THE ENTRANCE WHEN ITERATION IN STAGE B FAILS AND WE NEED C TO INCREASE N TO OBTAIN A BETTER ITERATIVE RATE. 6 CONTINUE C SOLVE (I-KN)*XN=RHFCN AT ALL TN(I).ALSO OBTAIN THE LU C DECOMPOSITION FOR LATER USE IN THE STAGE B ITERATIVE METHOD. C C******************************************************************* C * CALL LNSYS(IMKNN,LUFACT,NUP,N,XMZ,XN,2,IND) C * C LNSYS IS A GENERAL LINEAR EQUATION SOLVER. IT HAS SPECIAL * C OPTIONS WHICH ARE USED IN THE FOLLOWING PROGRAM. THUS IT * C SHOULD NOT BE REPLACED WITH ANOTHER SOLVER. LNSYS IS ALSO * C USED IN THE SUBROUTINE ITERT. * C * C******************************************************************* C COND=CONEW(COND,ELINSY,RELRSD,AVERR,PASTC,PASTRE) RELMIN=RMIN(N,N,COND,UNITRD,AVERR) IF(LOOP .EQ. 1) GO TO 11 IF(LOOP .EQ. 2) GO TO 9 C SET UP APPROXIMATE RATE OF CONVERGENCE OF SOLUTIONS XN TO TRUE C SOLUTION X. ALSO SET UP DESIRED RATIO FOR ITERATIVE METHOD. NUMR2=RNRM(XN,OLDX,N,1) R2=AMIN1(0.5,AMAX1(NUMR2/DENR2,1.0E-4)) R1RAT=AMIN1(ROOTRT,SQRT(R2)) C CHECK FOR ERROR IN XN USING TEST INVOLVING R2 AND OLDX,ACCORDING C TO THEORY FOR ASYMPTOTIC ERROR BOUNDS. MODIFY ERROR IF IT IS C OUTSIDE PRECISION RANGE OF COMPUTER, POSSIBLY DUE TO C ILL-CONDITIONING. 8 ERROR=(R2/(1.0-R2))*NUMR2 XNORM=RNRM(XN,XN,N,0) RELERR=ERROR/XNORM IF(IFLAG .EQ. 0) EPS=AMAX1(EP,XNORM*RELMIN) IF(IFLAG .EQ. 1) EPS=AMAX1(EP,RELMIN) IF(IFLAG .EQ. 1)ERROR=AMAX1(RELERR,RELMIN) IF((IFLAG .EQ. 0) .AND. (RELERR .LT. RELMIN)) * ERROR=RELMIN*XNORM IF(ERROR .LE. EPS) GO TO 10 DENR2=NUMR2 GO TO 11 C ENTRANCE FOR LOOP=2. 9 NUMR2=RNRM(XN,OLDX,N,1) DENR2=0.0 GO TO 8 C EXIT FOR SUCCESSFUL RETURN. ITERATION WAS NOT NECESSARY. 10 CALL LEAVE(0,N,N,XN,TN,WN,ERROR, * KERNEL,RHFCN,EP,IFLAG,X,T,NT,IER,EPS,ELINSY,TN,WN,TM,WM,XM, * XMZ,KMM,KMN,KNM,RHS,IMKNN,LUFACT,R,RH,DELN,NUP,NHALF,XNORM) RETURN C C ATTEMPT TO SOLVE (I-KM)*XM=RHFCN ITERATIVELY, CHECKING TO SEE IF C THE RATE OF CONVERGENCE IS SUFFICIENTLY FAST SO AS TO ENTER C STAGE B. C C CALCULATE TM(I) AND WM(I), I=1,...,M. 11 CALL WANDT(WM,TM,M,A,B) FLAG=0 C CALCULATE INITIAL GUESS XMZ FOR ITERATION METHOD. CALL NSTERP(TM,WM,XMZ,M,TN,WN,XN,N, * KERNEL,RHFCN,RHS,KMN,NHALF,NUP) DO 12 I=1,M 12 OLDX(I)=XMZ(I) C CALCULATE FIRST ITERATE. CALL ITERT(KERNEL,RHFCN,N,TN,WN,M,TM,WM,XM,XMZ,KMM,KMN,KNM, * RHS,IMKNN,LUFACT,R,RH,DELN,NUP,NHALF,FLAG) COND=CONEW(COND,ELINSY,RELRSD,AVERR,PASTC,PASTRE) DENR1=RNRM(XM,XMZ,M,1) FLAG=1 DO 13 I=1,M 13 XMZ(I)=XM(I) C CALCULATE SECOND ITERATE. CALL ITERT(KERNEL,RHFCN,N,TN,WN,M,TM,WM,XM,XMZ,KMM,KMN,KNM, * RHS,IMKNN,LUFACT,R,RH,DELN,NUP,NHALF,FLAG) COND=CONEW(COND,ELINSY,RELRSD,AVERR,PASTC,PASTRE) NUMR1=RNRM(XM,XMZ,M,1) C CHECK ON THE SPEED OF CONVERGENCE OF ITERATIVE METHOD. IF IT IS C SUFFICIENTLY RAPID, THEN FIX N AND GO TO STAGE B. R1=AMAX1(NUMR1/DENR1,.0001) RATE=R1 IF(M .GT. NUP) GO TO 19 IF(R1 .LE. R1RAT) GO TO 15 C THE ITERATION DID NOT WORK WELL ENOUGH, AND STAGE A IS TO BE C REPEATED. RE-INITIALIZE FOR SOLVING (I-KN)*XN=RHFCN AGAIN C WITH A LARGER N. 14 N=M LOOP=LOOP+1 M=2*N GO TO 3 C THE ITERATIVE RATE IS SUFFICIENTLY RAPID, AND CONTROL WILL GO TO C STAGE B. SAVE INFORMATION IN CASE STAGE B ABORTS AT A LARGER C VALUE OF M AND STAGE A HAS TO BE RETURNED TO. 15 DO 16 I=1,M ASIDE(I,1)=OLDX(I) ASIDE(I,2)=WM(I) ASIDE(I,3)=TM(I) 16 ASIDE(I,4)=RHS(I) ASIDE2(1)=LOOP ASIDE2(3)=R2 ASIDE2(4)=DENR2 ASIDE2(5)=R1RAT DO 17 J=1,M DO 17 I=1,M 17 ASIDE3(I,J)=KMM(I,J) C C STAGE B. ITERATIVE METHOD OF SOLUTION OF (I-KM)*XM=RHS. C 19 OLDM=N ASIDE2(2)=M IF(R1 .LE. CUTOFF) GO TO 22 C THE ITERATES ARE CONVERGING VERY SLOWLY OR NOT AT ALL. THUS C RETURN WITHOUT FURTHER ATTEMPTS TO LESSEN THE ERROR. IF(LOOP .NE. 1) GO TO 21 20 CALL LEAVE(2,N,N,XN,TN,WN,0.0, * KERNEL,RHFCN,EP,IFLAG,X,T,NT,IER,EPS,ELINSY,TN,WN,TM,WM,XM, * XMZ,KMM,KMN,KNM,RHS,IMKNN,LUFACT,R,RH,DELN,NUP,NHALF,XNORM) RETURN 21 CALL LEAVE(1,N,N,XN,TN,WN,ERROR, * KERNEL,RHFCN,EP,IFLAG,X,T,NT,IER,EPS,ELINSY,TN,WN,TM,WM,XM, * XMZ,KMM,KMN,KNM,RHS,IMKNN,LUFACT,R,RH,DELN,NUP,NHALF,XNORM) RETURN C TEST TO SEE IF THE CURRENT ITERATE XM IS SUFFICIENTLY ACCURATE C COMPARED TO THE TRUE XM. 22 RATE=R1*RATE TEMP=RNRM(XM,OLDX,M,1) IF(LOOP .EQ. 1) TEMP2=0.5 IF(LOOP .GT. 1) TEMP2=TEMP/DENR2 RT= AMIN1(0.01,AMAX1(TEMP2,0.0001))/2.0 XNORM=RNRM(XM,XM,M,0) ESTERR=(RT/(1.0-RT))*TEMP/XNORM IF(ESTERR .LT. RELMIN) ESTERR=RELMIN ESTERR=ESTERR*XNORM TEST=((1.0-R1)/R1)*ESTERR IF(NUMR1 .LE. TEST) GO TO 33 C ITERATE NOT SUFFICIENTLY ACCURATE. INITIALIZE FOR COMPUTATION C OF ANOTHER ITERATE. 25 DENR1=NUMR1 DO 26 I=1,M 26 XMZ(I)=XM(I) CALL ITERT(KERNEL,RHFCN,N,TN,WN,M,TM,WM,XM,XMZ,KMM,KMN,KNM, * RHS,IMKNN,LUFACT,R,RH,DELN,NUP,NHALF,FLAG) COND=CONEW(COND,ELINSY,RELRSD,AVERR,PASTC,PASTRE) NUMR1=RNRM(XM,XMZ,M,1) R1=AMAX1(NUMR1/DENR1,.0001) IF(R1 .LE. CUTOFF) GO TO 22 C THIS IS ENTRANCE FOR CASE WHERE ITERATION FAILS IN STAGE B. C PARAMETERS MUST BE RESET FOR A RETURN TO STAGE A OR FOR AN C ABORTIVE EXIT IF N CANNOT BE INCREASED ANY FURTHER. 27 MNEW=ASIDE2(2) IF(MNEW .GT. NUP) GO TO 30 N=MNEW DO 29 J=1,N DO 28 I=1,N 28 IMKNN(I,J)=-ASIDE3(I,J) OLDX(J)=ASIDE(J,1) WN(J)=ASIDE(J,2) TN(J)=ASIDE(J,3) XMZ(J)=ASIDE(J,4) 29 IMKNN(J,J)=IMKNN(J,J)+1.0 M=2*N LOOP=ASIDE2(1)+1.0 R2=ASIDE2(3) DENR2=ASIDE2(4) R1RAT=ASIDE2(5) GO TO 6 C ABORTIVE EXIT FROM STAGE B. N CANNOT BE INCREASED FURTHER, AND C R1 IS NOT SUFFICIENTLY SMALL. 30 IF(LOOP .EQ. 1) GO TO 20 CALL WANDT(WM,TM,OLDM,A,B) CALL LEAVE(1,N,OLDM,SAVE,TM,WM,ERROR, * KERNEL,RHFCN,EP,IFLAG,X,T,NT,IER,EPS,ELINSY,TN,WN,TM,WM,XM, * XMZ,KMM,KMN,KNM,RHS,IMKNN,LUFACT,R,RH,DELN,NUP,NHALF,XNORM) RETURN C AN ACCURATE VALUE OF XM HAS BEEN OBTAINED. R2 IS TO BE TESTED AS C TO WHETHER IT SHOULD BE RESET. THEN CHECK ERROR IN XM COMPARED C WITH THE TRUE SOLUTION X. 33 IF(LOOP .EQ. 1) GO TO 37 NUMR2=TEMP R2=AMAX1(1.0E-4,RATE,AMIN1(NUMR2/DENR2,0.5)) DENR2=NUMR2 34 ERROR=(R2/(1.0-R2))*TEMP XNORM=RNRM(XM,XM,M,0) RELERR=ERROR/XNORM RELMIN=RMIN(N,M,COND,UNITRD,AVERR) IF(IFLAG .EQ. 0) EPS=AMAX1(EP,XNORM*RELMIN) IF(IFLAG .EQ. 1) EPS=AMAX1(EP,RELMIN) IF(IFLAG .EQ. 1)ERROR=AMAX1(RELERR,RELMIN) IF((IFLAG .EQ. 0) .AND. (RELERR .LT. RELMIN)) * ERROR=RELMIN*XNORM IF(ERROR .GT. EPS) GO TO 35 CALL LEAVE(0,N,M,XM,TM,WM,ERROR, * KERNEL,RHFCN,EP,IFLAG,X,T,NT,IER,EPS,ELINSY,TN,WN,TM,WM,XM, * XMZ,KMM,KMN,KNM,RHS,IMKNN,LUFACT,R,RH,DELN,NUP,NHALF,XNORM) RETURN 35 MNEW=2*M IF(MNEW .LE. MUP) GO TO 39 C M CANNOT BE INCREASED ANY FURTHER. CALL LEAVE(1,N,M,XM,TM,WM,ERROR, * KERNEL,RHFCN,EP,IFLAG,X,T,NT,IER,EPS,ELINSY,TN,WN,TM,WM,XM, * XMZ,KMM,KMN,KNM,RHS,IMKNN,LUFACT,R,RH,DELN,NUP,NHALF,XNORM) RETURN 37 DENR2=TEMP LOOP=2 GO TO 34 C ERROR NOT SUFFICIENTLY SMALL. M IS INCREASED AND TWO MORE C MORE ITERATES ARE COMPUTED WITH THE NEW M. 39 OLDM=M M=MNEW DO 41 I=1,OLDM SAVE2(I)=WM(I) 41 SAVE(I)=TM(I) CALL WANDT(WM,TM,M,A,B) FLAG=0 CALL NSTERP(TM,WM,XMZ,M,SAVE,SAVE2,XM,OLDM, * KERNEL,RHFCN,RHS,KMN,NHALF,NUP) DO 43 I=1,OLDM 43 SAVE(I)=XM(I) DO 45 I=1,M 45 OLDX(I)=XMZ(I) CALL ITERT(KERNEL,RHFCN,N,TN,WN,M,TM,WM,XM,XMZ,KMM,KMN,KNM, * RHS,IMKNN,LUFACT,R,RH,DELN,NUP,NHALF,FLAG) COND=CONEW(COND,ELINSY,RELRSD,AVERR,PASTC,PASTRE) DENR1=RNRM(XM,XMZ,M,1) FLAG=1 DO 47 I=1,M 47 XMZ(I)=XM(I) CALL ITERT(KERNEL,RHFCN,N,TN,WN,M,TM,WM,XM,XMZ,KMM,KMN,KNM, * RHS,IMKNN,LUFACT,R,RH,DELN,NUP,NHALF,FLAG) COND=CONEW(COND,ELINSY,RELRSD,AVERR,PASTC,PASTRE) NUMR1=RNRM(XM,XMZ,M,1) R1=AMAX1(NUMR1/DENR1,.0001) RATE=R1 IF(R1 .LE. CUTOFF) GO TO 22 GO TO 27 END SUBROUTINE NSTERP(TM,WM,XM,M,TN,WN,XN,N,KERNEL,RHFCN,RHS,KMN, * NHALF,NUP) C C USE THE VALUES OF XN(I), I=1,...,N, TO CALCULATE THE NYSTROM C INTERPOLATES XM(I), I=1,...,M. C REAL KERNEL,KMN DIMENSION TM(M),WM(M),XM(M),TN(N),WN(N),XN(N),RHS(M), * KMN(NUP,NHALF) EXTERNAL KERNEL,RHFCN C IF(M .GT. NUP) GO TO 4 C SINCE M .LE. NUPPER, SAVE K(TM(I),TN(J))=KMN(I,J) AND C RHS(I)=RHFCN(TM(I)) FOR LATER USE IN ITERT. DO 1 I=1,M DO 1 J=1,N 1 KMN(I,J)=WN(J)*KERNEL(TM(I),TN(J)) DO 2 I=1,M RHS(I)=RHFCN(TM(I)) 2 XM(I)=RHS(I) C CALCULATE NYSTROM INTERPOLATING FORMULA. DO 3 I=1,M DO 3 J=1,N 3 XM(I)=XM(I)+KMN(I,J)*XN(J) RETURN C M .GT. NUPPER, SO SAVE JUST RHS(I) FOR LATER USE IN ITERT. C CALCULATE NYSTROM INTERPOLATING FORMULA. 4 DO 5 I=1,M RHS(I)=RHFCN(TM(I)) XM(I)=RHS(I) DO 5 J=1,N 5 XM(I)=XM(I)+WN(J)*KERNEL(TM(I),TN(J))*XN(J) RETURN END FUNCTION RMIN(N,M,COND,UNITRD,AVERR) C C FOR A LINEAR SYSTEM (I-KMM)*XM=RHFCN OF ORDER M, THIS IS THE C VALUE OF RELMIN USED IN IEGS. THE VARIABLE UNITRD IS DEFINED IN C IEGAUS, AND THE VARIABLES COND AND AVERR ARE DEFINED IN IEGS C USING CONEW. C IT IS UNLIKELY THAT A SOLUTION X CAN BE FOUND FOR THE ORIGINAL C INTEGRAL EQUATION WITH A SMALLER RELATIVE ERROR THAN RMIN. C FLOAT1=M FLOAT2=FLOAT(M)/FLOAT(N) RMIN=AMAX1((FLOAT1**1.5)*COND*UNITRD, * (FLOAT2**1.5)*AVERR) RETURN END REAL FUNCTION RNRM(X,Y,N,IFLAG) C C IFLAG=0 CALCULATE THE MAXIMUM NORM OF X. C IFLAG=1 CALCULATE THE MAXIMUM NORM OF X-Y. C DIMENSION X(N),Y(N) IF(IFLAG .EQ. 1) GO TO 2 C FIND THE NORM OF X. RNRM=0.0 DO 1 I=1,N 1 RNRM=AMAX1(RNRM,ABS(X(I))) RETURN C FIND THE NORM OF X-Y. 2 RNRM=0.0 DO 3 I=1,N 3 RNRM=AMAX1(RNRM,ABS(X(I)-Y(I))) RETURN END FUNCTION CONEW(COND,ELINSY,RELRSD,AVERR,PASTC,PASTRE) C C THIS IS USED IN UPDATING THE VALUE OF THE CONDITION NUMBER C IN IEGS. C AVERR=SQRT(ELINSY*PASTRE) PASTRE=ELINSY IF(RELRSD .EQ. 0.0) GO TO 1 C=AMAX1(1.0,ELINSY/RELRSD) CONEW=SQRT(C*PASTC) PASTC=C RETURN 1 CONEW=COND RETURN END SUBROUTINE WANDT(WV,TV,N,A,B) C C INTEGRATION WEIGHTS AND NODES ARE TO BE CALCULATED AND STORED IN C WV AND TV, RESPECTIVELY. N IS ASSUMED TO BE A POWER OF TWO. IF C 2 .LE. N .LE. 256, THEN GAUSSIAN QUADRATURE IS USED. IF N .GT. C 256, THEN THE INTERVAL (A,B) IS DIVIDED N/256 TIMES AND THE 256 C POINT FORMULA IS APPLIED TO EACH SUBINTERVAL. C DIMENSION WV(N),TV(N) DIMENSION W(255),T(255) DATA T(1),T(2),T(3),T(4),T(5),T(6),T(7),T(8),T(9),T(10),T(11), * T(12),T(13),T(14),T(15)/.577350269189626E0, * .861136311594053E0,.339981043584856E0,.960289856497536E0, * .796666477413627E0,.525532409916329E0,.183434642495650E0, * .989400934991650E0,.944575023073233E0,.865631202387832E0, * .755404408355003E0,.617876244402644E0,.458016777657227E0, * .281603550779259E0,.950125098376374E-1/ DATA T(16),T(17),T(18),T(19),T(20),T(21),T(22),T(23),T(24),T(25), * T(26),T(27),T(28),T(29),T(30),T(31)/.997263861849482E0, * .985611511545268E0,.964762255587506E0,.934906075937740E0, * .896321155766052E0,.849367613732570E0,.794483795967942E0, * .732182118740290E0,.663044266930215E0,.587715757240762E0, * .506899908932229E0,.421351276130635E0,.331868602282128E0, * .239287362252137E0,.144471961582796E0,.483076656877383E-1/ DATA T(32),T(33),T(34),T(35),T(36),T(37),T(38),T(39),T(40),T(41), * T(42),T(43),T(44),T(45),T(46),T(47)/.999305041735772E0, * .996340116771955E0,.991013371476744E0,.983336253884626E0, * .973326827789911E0,.961008799652054E0,.946411374858403E0, * .929569172131940E0,.910522137078503E0,.889315445995114E0, * .865999398154093E0,.840629296252580E0,.813265315122798E0, * .783972358943341E0,.752819907260532E0,.719881850171611E0/ DATA T(48),T(49),T(50),T(51),T(52),T(53),T(54),T(55),T(56),T(57), * T(58),T(59),T(60),T(61),T(62),T(63)/.685236313054233E0, * .648965471254657E0,.611155355172393E0,.571895646202634E0, * .531279464019895E0,.489403145707053E0,.446366017253464E0, * .402270157963992E0,.357220158337668E0,.311322871990211E0, * .264687162208767E0,.217423643740007E0,.169644420423993E0, * .121462819296121E0,.729931217877990E-1,.243502926634244E-1/ DATA T(64),T(65),T(66),T(67),T(68),T(69),T(70),T(71),T(72),T(73), * T(74),T(75),T(76),T(77),T(78),T(79)/.999824887947132E0, * .999077459977376E0,.997733248625514E0,.995792758534981E0, * .993257112900213E0,.990127818491734E0,.986406742724586E0, * .982096108435719E0,.977198491463907E0,.971716818747137E0, * .965654366431965E0,.959014757853700E0,.951801961341264E0, * .944020287830220E0,.935674388277916E0,.926769250878948E0/ DATA T(80),T(81),T(82),T(83),T(84),T(85),T(86),T(87),T(88),T(89), * T(90),T(91),T(92),T(93),T(94),T(95),T(96),T(97)/ * .917310198080961E0,.907302883401757E0,.896753288049158E0, * .885667717345397E0,.874052796958032E0,.861915468939548E0, * .849262987577969E0,.836102915060907E0,.822443116955644E0, * .808291757507914E0,.793657294762193E0,.778548475506412E0, * .762974330044095E0,.746944166797062E0,.730467566741909E0, * .713554377683587E0,.696214708369514E0,.678458922447719E0/ DATA T(98),T(99),T(100),T(101),T(102),T(103),T(104),T(105),T(106), * T(107),T(108),T(109),T(110),T(111),T(112),T(113),T(114)/ * .660297632272646E0,.641741692562308E0,.622802193910585E0, * .603490456158549E0,.583818021628763E0,.563796648226618E0, * .543438302412810E0,.522755152051175E0,.501759559136144E0, * .480464072404172E0,.458881419833552E0,.437024501037104E0, * .414906379552275E0,.392540275033267E0,.369939555349859E0, * .347117728597636E0,.324088435024413E0/ DATA T(115),T(116),T(117),T(118),T(119),T(120),T(121),T(122), * T(123),T(124),T(125),T(126),T(127)/.300865438877677E0, * .277462620177904E0,.253893966422694E0,.230173564226660E0, * .206315590902079E0,.182334305985337E0,.158244042714225E0, * .134059199461188E0,.109794231127644E0, * .854636405045155E-1,.610819696041396E-1,.366637909687335E-1, * .122236989606158E-1/ DATA T(128),T(129),T(130),T(131),T(132),T(133),T(134),T(135), * T(136),T(137),T(138),T(139),T(140),T(141),T(142)/ * .999956050018992E0,.999768437409263E0,.999430937466261E0, * .998943525843409E0,.998306266473006E0,.997519252756721E0, * .996582602023382E0,.995496454481096E0,.994260972922410E0, * .992876342608822E0,.991342771207583E0,.989660488745065E0, * .987829747564861E0,.985850822286126E0,.983724009760315E0/ DATA T(143),T(144),T(145),T(146),T(147),T(148),T(149),T(150), * T(151),T(152),T(153),T(154),T(155),T(156),T(157)/ * .981449629025464E0,.979028021257622E0,.976459549719234E0, * .973744599704370E0,.970883578480743E0,.967876915228489E0, * .964725060975706E0,.961428488530732E0,.957987692411178E0, * .954403188769716E0,.950675515316628E0,.946805231239127E0, * .942792917117462E0,.938639174837814E0, .934344627502003E0/ DATA T(158),T(159),T(160),T(161),T(162),T(163),T(164),T(165), * T(166),T(167),T(168),T(169),T(170),T(171),T(172)/ * .929909919334006E0,.925335715583316E0,.920622702425146E0, * .915771586857490E0,.910783096595065E0,.905657979960145E0, * .900397005770304E0,.895000963223085E0,.889470661777611E0, * .883806931033158E0,.878010620604707E0,.872082599995488E0, * .866023758466555E0,.859835004903376E0,.853517267679503E0/ DATA T(173),T(174),T(175),T(176),T(177),T(178),T(179),T(180), * T(181),T(182),T(183),T(184),T(185),T(186),T(187)/ * .847071494517296E0,.840498652345763E0,.833799727155505E0, * .826975723850813E0,.820027666098917E0,.812956596176432E0, * .805763574812999E0,.798449681032171E0,.791016011989546E0, * .783463682808184E0,.775793826411326E0,.768007593352446E0, * .760106151642655E0,.752090686575492E0,.743962400549112E0/ DATA T(188),T(189),T(190),T(191),T(192),T(193),T(194),T(195), * T(196),T(197),T(198),T(199),T(200),T(201),T(202)/ * .735722512885918E0,.727372259649652E0,.718912893459971E0, * .710345683304543E0,.701671914348685E0,.692892887742577E0, * .684009920426076E0,.675024344931163E0,.665937509182049E0, * .656750776292973E0,.647465524363725E0,.638083146272911E0, * .628605049469015E0,.619032655759261E0,.609367401096334E0/ DATA T(203),T(204),T(205),T(206),T(207),T(208),T(209),T(210), * T(211),T(212),T(213),T(214),T(215),T(216),T(217)/ * .599610735362968E0,.589764122154454E0,.579829038559083E0, * .569806974936569E0,.559699434694481E0,.549507934062719E0, * .539234001866059E0,.528879179294822E0,.518445019673674E0, * .507933088228616E0,.497344961852181E0,.486682228866890E0, * .475946488786983E0,.465139352078479E0,.454262439917590E0/ DATA T(218),T(219),T(220),T(221),T(222),T(223),T(224),T(225), * T(226),T(227),T(228),T(229),T(230),T(231),T(232)/ * .443317383947527E0,.432305826033741E0,.421229418017624E0, * .410089821468717E0,.398888707435459E0,.387627756194516E0, * .376308656998716E0,.364933107823654E0,.353502815112970E0, * .342019493522372E0,.330484865662417E0,.318900661840106E0, * .307268619799319E0,.295590484460136E0,.283868007657082E0/ DATA T(233),T(234),T(235),T(236),T(237),T(238),T(239),T(240), * T(241),T(242),T(243),T(244),T(245),T(246),T(247)/ * .272102947876337E0,.260297069991943E0,.248452145001057E0, * .236569949758284E0,.224652266709132E0,.212700883622626E0, * .200717593323127E0,.188704193421389E0,.176662486044902E0, * .164594277567554E0,.152501378338656E0,.140385602411376E0, * .128248767270607E0,.116092693560333E0,.103919204810509E0/ DATA T(248),T(249),T(250),T(251),T(252),T(253),T(254),T(255)/ * .917301271635196E-1,.795272891002330E-1,.673125211657164E-1, * .550876556946340E-1,.428545265363791E-1,.306149687799790E-1, * .183708184788137E-1,.612391237518953E-2/ DATA W(1),W(2),W(3),W(4),W(5),W(6),W(7),W(8),W(9),W(10),W(11), * W(12),W(13),W(14),W(15)/1.0E0,.347854845137454E0, * .652145154862546E0,.101228536290376E0,.222381034453374E0, * .313706645877887E0,.362683783378362E0,.271524594117541E-1, * .622535239386479E-1,.951585116824928E-1,.124628971255534E0, * .149595988816577E0,.169156519395003E0,.182603415044924E0, * .189450610455068E0/ DATA W(16),W(17),W(18),W(19),W(20),W(21),W(22),W(23),W(24),W(25), * W(26),W(27),W(28),W(29),W(30),W(31)/.701861000947010E-2, * .162743947309057E-1,.253920653092621E-1,.342738629130214E-1, * .428358980222267E-1,.509980592623762E-1,.586840934785355E-1, * .658222227763618E-1,.723457941088485E-1,.781938957870703E-1, * .833119242269468E-1,.876520930044038E-1,.911738786957639E-1, * .938443990808046E-1,.956387200792749E-1,.965400885147278E-1/ DATA W(32),W(33),W(34),W(35),W(36),W(37),W(38),W(39),W(40),W(41), * W(42),W(43),W(44),W(45),W(46),W(47)/.178328072169643E-2, * .414703326056247E-2,.650445796897836E-2,.884675982636395E-2, * .111681394601311E-1,.134630478967186E-1,.157260304760247E-1, * .179517157756973E-1,.201348231535302E-1,.222701738083833E-1, * .243527025687109E-1,.263774697150547E-1,.283396726142595E-1, * .302346570724025E-1,.320579283548516E-1,.338051618371416E-1/ DATA W(48),W(49),W(50),W(51),W(52),W(53),W(54),W(55),W(56),W(57), * W(58),W(59),W(60),W(61),W(62),W(63)/ .354722132568824E-1, * .370551285402400E-1,.385501531786156E-1,.399537411327203E-1, * .412625632426235E-1,.424735151236536E-1,.435837245293235E-1, * .445905581637566E-1,.454916279274181E-1, .462847965813144E-1, * .469681828162100E-1,.475401657148303E-1,.479993885964583E-1, * .483447622348030E-1,.485754674415034E-1,.486909570091397E-1/ DATA W(64),W(65),W(66),W(67),W(68),W(69),W(70),W(71),W(72),W(73), * W(74),W(75),W(76),W(77),W(78),W(79)/ .449380960292090E-3, * .104581267934035E-2,.164250301866903E-2,.223828843096262E-2, * .283275147145799E-2,.342552604091022E-2,.401625498373864E-2, * .460458425670296E-2,.519016183267633E-2,.577263754286570E-2, * .635166316170719E-2,.692689256689881E-2,.749798192563473E-2, * .806458989048606E-2,.862637779861675E-2,.918300987166087E-2/ DATA W(80),W(81),W(82),W(83),W(84),W(85),W(86),W(87),W(88), * W(89),W(90),W(91),W(92),W(93),W(94),W(95)/.973415341500681E-2, * .102794790158322E-1,.108186607395031E-1,.113513763240804E-1, * .118773073727403E-1,.123961395439509E-1,.129075627392673E-1, * .134112712886163E-1,.139069641329520E-1,.143943450041668E-1, * .148731226021473E-1,.153430107688651E-1,.158037286593993E-1, * .162550009097852E-1,.166965578015892E-1,.171281354231114E-1/ DATA W(96),W(97),W(98),W(99),W(100),W(101),W(102),W(103),W(104), * W(105),W(106),W(107),W(108),W(109),W(110),W(111),W(112)/ * .175494758271177E-1,.179603271850087E-1,.183604439373313E-1, * .187495869405447E-1,.191275236099509E-1,.194940280587066E-1, * .198488812328309E-1,.201918710421300E-1,.205227924869601E-1, * .208414477807511E-1,.211476464682213E-1,.214412055392085E-1, * .217219495380521E-1,.219897106684605E-1,.222443288937998E-1, * .224856520327450E-1,.227135358502365E-1/ DATA W(113),W(114),W(115),W(116),W(117),W(118),W(119),W(120), * W(121),W(122),W(123),W(124),W(125),W(126),W(127)/ * .229278441436868E-1,.231284488243870E-1,.233152299940628E-1, * .234880760165359E-1,.236468835844476E-1,.237915577810034E-1, * .239220121367035E-1,.240381686810241E-1,.241399579890193E-1, * .242273192228152E-1,.243002001679719E-1,.243585572646906E-1, * .244023556338496E-1,.244315690978500E-1,.244461801962625E-1/ DATA W(128),W(129),W(130),W(131),W(132),W(133),W(134),W(135), * W(136),W(137),W(138),W(139),W(140),W(141),W(142)/ * .112789017822272E-3,.262534944296446E-3,.412463254426176E-3, * .562348954031410E-3,.712154163473321E-3,.861853701420089E-3, * .101142439320844E-2,.116084355756772E-2,.131008868190250E-2, * .145913733331073E-2,.160796713074933E-2,.175655573633073E-2, * .190488085349972E-2,.205292022796614E-2,.220065164983991E-2/ DATA W(143),W(144),W(145),W(146),W(147),W(148),W(149),W(150), * W(151),W(152),W(153),W(154),W(155),W(156),W(157)/ * .234805295632731E-2,.249510203470371E-2,.264177682542749E-2, * .278805532532771E-2,.293391559082972E-2,.307933574119934E-2, * .322429396179420E-2,.336876850731555E-2,.351273770505631E-2, * .365617995814250E-2,.379907374876626E-2,.394139764140883E-2, * .408313028605267E-2,.422425042138154E-2,.436473687796806E-2/ DATA W(158),W(159),W(160),W(161),W(162),W(163),W(164),W(165), * W(166),W(167),W(168),W(169),W(170),W(171),W(172)/ * .450456858144790E-2,.464372455568006E-2,.478218392589269E-2, * .491992592181387E-2,.505692988078684E-2,.519317525086928E-2, * .532864159391593E-2,.546330858864431E-2,.559715603368291E-2, * .573016385060144E-2,.586231208692265E-2,.599358091911534E-2, * .612395065556793E-2,.625340173954240E-2,.638191475210788E-2/ DATA W(173),W(174),W(175),W(176),W(177),W(178),W(179),W(180), * W(181),W(182),W(183),W(184),W(185),W(186),W(187)/ * .650947041505366E-2,.663604959378107E-2,.676163330017380E-2, * .688620269544632E-2,.700973909296982E-2,.713222396107539E-2, * .725363892583391E-2,.737396577381235E-2,.749318645480588E-2, * .761128308454566E-2,.772823794738156E-2,.784403349893971E-2, * .795865236875435E-2,.807207736287350E-2,.818429146643827E-2/ DATA W(188),W(189),W(190),W(191),W(192),W(193),W(194),W(195), * W(196),W(197),W(198),W(199),W(200),W(201),W(202)/ * .829527784623523E-2,.840501985322154E-2,.851350102502249E-2, * .862070508840101E-2,.872661596169881E-2,.883121775724875E-2, * .893449478375821E-2,.903643154866287E-2,.913701276045081E-2, * .923622333095630E-2,.933404837762327E-2,.943047322573775E-2, * .952548341062928E-2,.961906467984073E-2,.971120299526628E-2/ DATA W(203),W(204),W(205),W(206),W(207),W(208),W(209),W(210), * W(211),W(212),W(213),W(214),W(215),W(216),W(217)/ * .980188453525733E-2,.989109569669583E-2,.997882309703491E-2, * .100650535763064E-1,.101497741990949E-1,.102329722564782E-1, * .103146352679340E-1,.103947509832117E-1,.104733073841704E-1, * .105502926865815E-1,.106256953418966E-1,.106995040389798E-1, * .107717077058046E-1,.108422955111148E-1,.109112568660490E-1/ DATA W(218),W(219),W(220),W(221),W(222),W(223),W(224),W(225), * W(226),W(227),W(228),W(229),W(230),W(231),W(232)/ * .109785814257296E-1,.110442590908139E-1,.111082800090098E-1, * .111706345765534E-1,.112313134396497E-1,.112903074958755E-1, * .113476078955455E-1,.114032060430392E-1,.114570935980906E-1, * .115092624770395E-1,.115597048540436E-1,.116084131622531E-1, * .116553800949452E-1,.117005986066207E-1,.117440619140606E-1/ DATA W(233),W(234),W(235),W(236),W(237),W(238),W(239),W(240), * W(241),W(242),W(243),W(244),W(245),W(246),W(247)/ * .117857634973434E-1,.118256971008240E-1,.118638567340711E-1, * .119002366727665E-1,.119348314595636E-1,.119676359049059E-1, * .119986450878058E-1,.120278543565826E-1,.120552593295601E-1, * .120808558957245E-1,.121046402153405E-1,.121266087205273E-1, * .121467581157945E-1,.121650853785355E-1,.121815877594818E-1/ DATA W(248),W(249),W(250),W(251),W(252),W(253),W(254),W(255)/ * .121962627831147E-1,.122091082480372E-1,.122201222273040E-1, * .122293030687103E-1,.122366493950402E-1,.122421601042728E-1, * .122458343697479E-1,.122476716402898E-1/ LOOP=MAX0(1,N/256) FLOOP=LOOP H=(B-A)/FLOOP SCALE=H/2.0 M=MIN0(128,N/2) MT=2*M NPLACE=M-1 DO 1 L=1,LOOP FL=L AL=A+(FL-1.0)*H BL=A+FL*H K=256*(L-1) DO 1 I=1,M NPI=NPLACE+I S=T(NPI) R=W(NPI)*SCALE I1=K+I I2=K+MT+1-I TV(I1)= (AL*(1.0+S)+(1.0-S)*BL)/2.0 TV(I2)= (AL*(1.0-S)+(1.0+S)*BL)/2.0 WV(I1)=R 1 WV(I2)=R RETURN END SUBROUTINE LEAVE(IERSET,NF,MF,XV,TV,WV,ERROR,KERNEL,RHFCN,EP, * IFLAG,X,T,NT,IER,EPS,ELINSY,TN,WN,TM,WM,XM,XMZ,KMM,KMN,KNM, * RHS,IMKNN,LUFACT,R,RH,DELN,NUP,NHALF,XNORM) C C THIS ROUTINE SETS ALL NECESSARY PARAMETERS FOR LEAVING IEGAUS. C IF NT .GT. 0, IT ALSO PERFORMS THE NECESSARY NYSTROM C INTERPOLATION AT THE NODES GIVEN IN T. C REAL KERNEL,KMM,KMN,KNM,IMKNN,LUFACT,NORMK,NUMR1 DIMENSION X(*),T(*),XV(MF),TV(MF),WV(MF),TN(NF),WN(NF),WM(MF), * XM(MF),XMZ(MF),KMM(NUP,NUP),KMN(NUP,NHALF),KNM(NHALF,NUP), * RHS(MF),IMKNN(NUP,NUP),LUFACT(NUP,NUP),R(MF),RH(NF), * TM(MF),DELN(NF) COMMON/XXINFO/R1,R2,FINLEP,NORMK,NFINAL,MFINAL EXTERNAL KERNEL,RHFCN C C SET ERROR PARAMETERS FOR RETURN. C NORMK=0.0 NFINAL=NF MFINAL=MF FINLEP=EPS IF((EPS .GT. EP) .AND. (ERROR .LE. EPS)) GO TO 10 IER=IERSET EP=ERROR IF(NT .EQ. 0) GO TO 20 GO TO 30 10 IER=3 C C SINCE EPS IS THE SMALLEST ERROR POSSIBLE, SET EP=EPS FOR THE C RETURN ERROR ESTIMATE. C EP=EPS IF(NT .GT. 0) GO TO 30 C C NO NYSTROM INTERPOLATION IS DESIRED. RETURN THE VALUES AT THE C GAUSSIAN NODE POINTS. C 20 DO 21 I=1,MF X(I)=XV(I) 21 T(I)=TV(I) NT=MF RETURN C CALCULATE NORM(K). 30 SAVEP=EP DO 31 I=1,NF 31 IMKNN(I,I)=IMKNN(I,I)-1.0 NORMK=0.0 DO 33 I=1,NF SUM=0.0 DO 32 J=1,NF 32 SUM=SUM+ABS(IMKNN(I,J)) 33 NORMK=AMAX1(NORMK,SUM) DO 34 I=1,NF 34 IMKNN(I,I)=IMKNN(I,I)+1.0 IF(NF .EQ. MF) GO TO 50 C C ITERATE TO DECREASE THE NOISE LEVEL IN X. THIS SHOULD REDUCE C POSSIBLE ERRORS IN NYSTROM INTERPOLATION. C DERROR=((1.0-R1)/R1)*EPS/NORMK IF(IFLAG .EQ. 1) DERROR=DERROR*XNORM ITLOOP=0 DO 41 I=1,MF 41 XM(I)=XV(I) 42 DO 43 I=1,MF 43 XMZ(I)=XM(I) CALL ITERT(KERNEL,RHFCN,NF,TN,WN,MF,TM,WM,XM,XMZ,KMM,KMN,KNM, * RHS,IMKNN,LUFACT,R,RH,DELN,NUP,NHALF,1) NUMR1=RNRM(XM,XMZ,MF,1) ITLOOP=ITLOOP+1 IF((NUMR1 .GT. DERROR) .AND. (ITLOOP .LT. 5)) GO TO 42 DO 44 I=1,MF 44 XV(I)=XM(I) C C ESTIMATE NEW ERROR BOUND FOR NYSTROM INTERPOLATES. C TEMP=NORMK*(R1/(1.0-R1))*NUMR1 IF(IFLAG .EQ. 1) TEMP=TEMP/XNORM EP=AMAX1(EP,TEMP) GO TO 60 C C NO ITERATION USED IN COMPUTING X. JUST COMPUTE ERROR ESTIMATE C IN NYSTROM INTERPOLATE. C 50 TEMP=NORMK*ELINSY IF(IFLAG .EQ. 0) TEMP=TEMP*XNORM IF(IER .NE. 2) EP=AMAX1(EP,TEMP) C C COMPUTE NYSTROM INTERPOLATES AT THE NODES IN T. C 60 DO 62 I=1,NT SUM=0.0 DO 61 J=1,MF 61 SUM=SUM+WV(J)*KERNEL(T(I),TV(J))*XV(J) 62 X(I)=RHFCN(T(I))+SUM IF((IER .EQ. 0) .AND. (EP .GT. EPS)) IER=4 IF((IER .EQ. 1) .AND. (EP .GT. ERROR)) IER=5 IF((IER .EQ. 3) .AND. (EP .GT. EPS)) IER=6 EP=SAVEP RETURN END SUBROUTINE ITERT(KERNEL,RHFCN,N,TN,WN,M,TM,WM,XM,XMZ,KMM,KMN, * KNM,RHS,IMKNN,LUFACT,R,RH,DELN,NUP,NHALF,IFLG) C C THIS ROUTINE CALCULATES ONE ITERATE XM GIVEN THE INITIAL GUESS C XMZ. THE ROUTINE IS DIVIDED ACCORDING TO WHETHER OR NOT C M .GT. NUPPER. C REAL KERNEL,KMM,KMN,KNM,IMKNN,LUFACT DIMENSION TN(N),WN(N),TM(M),WM(M),XM(M),XMZ(M),KMM(NUP,NUP), * KMN(NUP,NHALF),KNM(NHALF,NUP),RHS(M),IMKNN(NUP,NUP), * LUFACT(NUP,NUP),R(M),RH(N),DELN(N) EXTERNAL KERNEL C C M .GT. NUPPER MEANS THAT THE MATRICES KMM,KMN,KNM CAN NO LONGER C BE STORED DUE TO LACK OF SPACE. IF (M .GT. NUP) GO TO 13 IF(IFLG .EQ. 1) GO TO 3 C IF IFLG=0, THEN THE MATRICES KMM AND KNM MUST BE COMPUTED C AND STORED. DO 2 J=1,M DO 1 I=1,M 1 KMM(I,J)=WM(J)*KERNEL(TM(I),TM(J)) DO 2 I=1,N 2 KNM(I,J)=WM(J)*KERNEL(TN(I),TM(J)) C COMPUTE RESIDUALS R(I)=RHFCN(TM(I))-XMZ(I)+KM(TM(I))*XMZ(I) 3 DO 5 I=1,M SUM=0.0 DO 4 J=1,M 4 SUM=SUM+KMM(I,J)*XMZ(J) 5 R(I)=RHS(I)-(XMZ(I)-SUM) C C COMPUTE RH=KM*R AT ALL TN(I). DO 7 I=1,N RH(I)=0.0 DO 7 J=1,M 7 RH(I)=RH(I)+KNM(I,J)*R(J) C CALCULATE DELN=((I-KN)**(-1))*KM*R AT ALL TN(I). C C******************************************************************* C * CALL LNSYS(IMKNN,LUFACT,NUP,N,RH,DELN,4,IND) C * C SEE THE ORIGINAL REFERENCE IN IEGS. * C******************************************************************* C C CALCULATE NEW XM. DO 12 I=1,M SUM=0.0 DO 10 J=1,M 10 SUM=SUM+KMM(I,J)*R(J) DO 11 J=1,N 11 SUM=SUM+KMN(I,J)*DELN(J) 12 XM(I)=SUM+R(I)+XMZ(I) RETURN C ENTRANCE WHEN M .GT. NUP. C CALCULATE RESIDUALS. 13 DO 15 I=1,M SUM=0.0 DO 14 J=1,M 14 SUM=SUM+WM(J)*KERNEL(TM(I),TM(J))*XMZ(J) 15 R(I)=RHS(I)-(XMZ(I)-SUM) C CALCULATE RH=KM*R. DO 17 I=1,N RH(I)=0.0 DO 17 J=1,M 17 RH(I)=RH(I)+WM(J)*KERNEL(TN(I),TM(J))*R(J) C C******************************************************************* C * CALL LNSYS(IMKNN,LUFACT,NUP,N,RH,DELN,4,IND) C * C SEE THE ORIGINAL REFERENCE IN IEGS. * C******************************************************************* C C CALCULATE XM. DO 22 I=1,M SUM=0.0 DO 20 J=1,M 20 SUM=SUM+WM(J)*KERNEL(TM(I),TM(J))*R(J) DO 21 J=1,N 21 SUM=SUM+WN(J)*KERNEL(TM(I),TN(J))*DELN(J) 22 XM(I)=SUM+R(I)+XMZ(I) RETURN END SUBROUTINE LNSYS(A,D,M,N,B,X,OPTION,IERR) C C SOLVE AX = B WHERE A IS A MATRIX OF ORDER N. M IS THE NUMBER OF C ROWS IN THE DIMENSION STATEMENT FOR A IN THE CALLING PROGRAM. C C OPTION=1 COMPUTE AN LU DECOMPOSITION OF A AND STORE IT IN D. C STORE THE PIVOT INDICES IN PIVOT AND SOLVE AX = B. C OPTION=2 COMPUTE AN LU DECOMPOSITION OF A AND STORE IT IN D. C STORE THE PIVOT INDICES IN PIVOT AND SOLVE AX = B. C THEN COMPUTE THE RESIDUAL AND ONE CORRECTION. THE C CORRECTION IS STORED IN R, THE NEW VALUE X1 IN X, C THE RELATIVE ERROR C NORM(X0-X1)/NORM(X1) C IN THE VARIABLE ERROR, AND THE RELATIVE RESIDUAL C NORM(RESIDUAL)/NORM(B) C IN THE VARIABLE RELRSD. THESE VALUES CAN BE OBTAINED C USING THE COMMON/XXLIN/ GIVEN BELOW. C OPTION=3 SAME AS OPTION=1, EXCEPT THAT THE LU DECOMPOSITION C HAS ALREADY BEEN STORED IN D AND THE PIVOT INDICES C IN PIVOT. C OPTION=4 SAME AS OPTION=2, EXCEPT THAT THE LU DECOMPOSITION C HAS ALREADY BEEN STORED IN D AND THE PIVOT INDICES C IN PIVOT. C C THE LU DECOMPOSITION IS OBTAINED USING SCALED PARTIAL PIVOTING. C FOR OPTIONS 1 AND 2, IERR IS A VARIABLE THAT REPORTS THE STATUS C OF THE RESULTS. IERR = 0 IF THE LU DECOMPOSITION IS OBTAINED. C OTHERWISE, IERR = -K WHEN THE K-TH ROW OF A CONTAINS ONLY ZEROS C OR IERR = K WHEN THE K-TH PIVOT ELEMENT IS 0. C C IT IS ASSUMED THAT N .LE. 128. THIS ASSUMPTION MAY BE MODIFIED C BY CHANGING THE DIMENSION STATEMENTS FOR THE ARRAYS PIVOT, R, C AND SCALE. ALSO MODIFY THE DIMENSION STATEMENT FOR PIVOT IN THE C SUBROUTINE IEGS. C REAL A(M,N),D(M,N),B(N),X(N) INTEGER OPTION,PIVOT(128) REAL NORMX,NORME,NORMB,NORMR,R(128),SCALE(128) COMMON /XXLIN/ ERROR,RELRSD,PIVOT C NM1 = N - 1 ISWIT = 1 IF (OPTION .GT. 2) GO TO 100 C DO 11 I = 1,N SCALE(I) = 0.0 DO 10 J = 1,N D(I,J) = A(I,J) 10 SCALE(I) = SCALE(I) + ABS(D(I,J)) IF (SCALE(I) .NE. 0.0) GO TO 11 IERR = -I RETURN 11 CONTINUE C C OBTAIN THE LU DECOMPOSITION OF A C IERR = 0 DO 43 K = 1,NM1 C = ABS(D(K,K))/SCALE(K) L = K KP1 = K + 1 DO 20 I = KP1,N T = ABS(D(I,K))/SCALE(I) IF (T .LE. C) GO TO 20 C = T L = I 20 CONTINUE C IF (C .NE. 0.0) GO TO 30 IERR = K RETURN C C INTERCHANGE ROWS K AND L C 30 PIVOT(K) = L IF (K .EQ. L) GO TO 40 DO 31 J = K,N T = D(K,J) D(K,J) = D(L,J) 31 D(L,J) = T T = SCALE(K) SCALE(K) = SCALE(L) SCALE(L) = T C C ELIMINATE THE K-TH UNKNOWN BELOW THE DIAGONAL C 40 DO 42 I = KP1,N D(I,K) = D(I,K)/D(K,K) T = D(I,K) DO 41 J = KP1,N 41 D(I,J) = D(I,J) - T*D(K,J) 42 CONTINUE 43 CONTINUE C IF (D(N,N) .NE. 0.0) GO TO 100 IERR = N RETURN C C STORE B IN R AND SET X = 0 C 100 DO 110 I = 1,N R(I) = B(I) 110 X(I) = 0.0 GO TO 200 C C COMPUTE THE RESIDUAL R = B - AX C 120 DO 131 I = 1,N SUM = 0.0 DO 130 J = 1,N 130 SUM = SUM + A(I,J)*X(J) 131 R(I) = B(I) - SUM C NORMB = 0.0 NORMR = 0.0 DO 140 I = 1,N NORMB = AMAX1(NORMB,ABS(B(I))) 140 NORMR = AMAX1(NORMR,ABS(R(I))) RELRSD = 0.0 IF (NORMB .NE. 0.0) RELRSD = NORMR/NORMB ISWIT = 2 C C SOLVE LZ = R AND STORE Z IN R C 200 DO 212 K = 1,NM1 L = PIVOT(K) IF (K .EQ. L) GO TO 210 T = R(K) R(K) = R(L) R(L) = T 210 KP1 = K + 1 DO 211 I = KP1,N 211 R(I) = R(I) - D(I,K)*R(K) 212 CONTINUE C C SOLVE UE = R, STORE E IN R, AND SET X = X + E C R(N) = R(N)/D(N,N) X(N) = X(N) + R(N) DO 221 NMI = 1,NM1 I = N - NMI IP1 = I + 1 SUM = 0.0 DO 220 J = IP1,N 220 SUM = SUM + D(I,J)*R(J) R(I) = (R(I) - SUM)/D(I,I) 221 X(I) = X(I) + R(I) C GO TO (300,230,300,230),OPTION 230 IF (ISWIT .EQ. 1) GO TO 120 C C CALCULATE THE CORRECTION ERROR C NORMX = 0.0 NORME = 0.0 DO 250 I = 1,N NORMX = AMAX1(NORMX,ABS(X(I))) 250 NORME = AMAX1(NORME,ABS(R(I))) ERROR = 0.0 IF (NORMX .NE. 0.0) ERROR = NORME/NORMX 300 RETURN END SUBROUTINE ODE(F,NEQN,Y,T,TOUT,RELERR,ABSERR,IFLAG,WORK,IWORK) C C SANDIA MATHEMATICAL PROGRAM LIBRARY C APPLIED MATHEMATICS DIVISION 2642 C SANDIA LABORATORIES C ALBUQUERQUE, NEW MEXICO 87115 C JANUARY 1976 C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C * ISSUED BY SANDIA LABORATORIES, C * A PRIME CONTRACTOR TO THE C * UNITED STATES ENERGY RESEARCH AND DEVELOPMENT ADMINISTRATION C * * * * * * * * * * * * * * NOTICE * * * * * * * * * * * * * * * C * THIS REPORT WAS PREPARED AS AN ACCOUNT OF WORK SPONSORED BY THE C * UNITED STATES GOVERNMENT. NEITHER THE UNITED STATES NOR THE C * UNITED STATES ENERGY RESEARCH AND DEVELOPMENT ADMINISTRATION, C * NOR ANY OF THEIR EMPLOYEES, NOR ANY OF THEIR CONTRACTORS, C * SUBCONTRACTORS, OR THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS C * OR IMPLIED, OR ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY C * FOR THE ACCURACY, COMPLETENESS OR USEFULNESS OF ANY INFORMATION, C * APPARATUS, PRODUCT OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS C * USE WOULD NOT INFRINGE PRIVATELY OWNED RIGHTS. C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C WRITTEN BY L. F. SHAMPINE AND M. K. GORDON C C ABSTRACT C C SUBROUTINE ODE INTEGRATES A SYSTEM OF NEQN FIRST ORDER C ORDINARY DIFFERENTIAL EQUATIONS OF THE FORM C DY(I)/DT = F(T,Y(1),Y(2),...,Y(NEQN)) C Y(I) GIVEN AT T . C THE SUBROUTINE INTEGRATES FROM T TO TOUT . ON RETURN THE C PARAMETERS IN THE CALL LIST ARE SET FOR CONTINUING THE INTEGRATION. C THE USER HAS ONLY TO DEFINE A NEW VALUE TOUT AND CALL ODE AGAIN. C C THE DIFFERENTIAL EQUATIONS ARE ACTUALLY SOLVED BY A SUITE OF CODES C DE1, STEP1, AND INTRP . ODE ALLOCATES VIRTUAL STORAGE IN THE C ARRAYS WORK AND IWORK AND CALLS DE1. DE1 IS A SUPERVISOR WHICH C DIRECTS THE SOLUTION. IT CALLS ON THE ROUTINES STEP1 AND INTRP C TO ADVANCE THE INTEGRATION AND TO INTERPOLATE AT OUTPUT POINTS. C STEP1 USES A MODIFIED DIVIDED DIFFERENCE FORM OF THE ADAMS PECE C FORMULAS AND LOCAL EXTRAPOLATION. IT ADJUSTS THE ORDER AND STEP C SIZE TO CONTROL THE LOCAL ERROR PER UNIT STEP IN A GENERALIZED C SENSE. NORMALLY EACH CALL TO STEP1 ADVANCES THE SOLUTION ONE STEP C IN THE DIRECTION OF TOUT . FOR REASONS OF EFFICIENCY DE1 C INTEGRATES BEYOND TOUT INTERNALLY, THOUGH NEVER BEYOND C T+10*(TOUT-T), AND CALLS INTRP TO INTERPOLATE THE SOLUTION AT C TOUT . AN OPTION IS PROVIDED TO STOP THE INTEGRATION AT TOUT BUT C IT SHOULD BE USED ONLY IF IT IS IMPOSSIBLE TO CONTINUE THE C INTEGRATION BEYOND TOUT . C C THIS CODE IS COMPLETELY EXPLAINED AND DOCUMENTED IN THE TEXT, C COMPUTER SOLUTION OF ORDINARY DIFFERENTIAL EQUATIONS, THE INITIAL C VALUE PROBLEM BY L. F. SHAMPINE AND M. K. GORDON. C C THE PARAMETERS REPRESENT... C F -- SUBROUTINE F(T,Y,YP) TO EVALUATE DERIVATIVES YP(I)=DY(I)/DT C NEQN -- NUMBER OF EQUATIONS TO BE INTEGRATED C Y(*) -- SOLUTION VECTOR AT T C T -- INDEPENDENT VARIABLE C TOUT -- POINT AT WHICH SOLUTION IS DESIRED C RELERR,ABSERR -- RELATIVE AND ABSOLUTE ERROR TOLERANCES FOR LOCAL C ERROR TEST. AT EACH STEP THE CODE REQUIRES C ABS(LOCAL ERROR) .LE. ABS(Y)*RELERR + ABSERR C FOR EACH COMPONENT OF THE LOCAL ERROR AND SOLUTION VECTORS C IFLAG -- INDICATES STATUS OF INTEGRATION C WORK(*),IWORK(*) -- ARRAYS TO HOLD INFORMATION INTERNAL TO CODE C WHICH IS NECESSARY FOR SUBSEQUENT CALLS C C FIRST CALL TO ODE -- C C THE USER MUST PROVIDE STORAGE IN HIS CALLING PROGRAM FOR THE ARRAYS C IN THE CALL LIST, C Y(NEQN), WORK(100+21*NEQN), IWORK(5), C DECLARE F IN AN EXTERNAL STATEMENT, SUPPLY THE SUBROUTINE C F(T,Y,YP) TO EVALUATE C DY(I)/DT = YP(I) = F(T,Y(1),Y(2),...,Y(NEQN)) C AND INITIALIZE THE PARAMETERS... C NEQN -- NUMBER OF EQUATIONS TO BE INTEGRATED C Y(*) -- VECTOR OF INITIAL CONDITIONS C T -- STARTING POINT OF INTEGRATION C TOUT -- POINT AT WHICH SOLUTION IS DESIRED C RELERR,ABSERR -- RELATIVE AND ABSOLUTE LOCAL ERROR TOLERANCES C IFLAG -- +1,-1. INDICATOR TO INITIALIZE THE CODE. NORMAL INPUT C IS +1. THE USER SHOULD SET IFLAG=-1 ONLY IF IT IS C IMPOSSIBLE TO CONTINUE THE INTEGRATION BEYOND TOUT . C ALL PARAMETERS EXCEPT F , NEQN AND TOUT MAY BE ALTERED BY THE C CODE ON OUTPUT SO MUST BE VARIABLES IN THE CALLING PROGRAM. C C OUTPUT FROM ODE -- C C NEQN -- UNCHANGED C Y(*) -- SOLUTION AT T C T -- LAST POINT REACHED IN INTEGRATION. NORMAL RETURN HAS C T = TOUT . C TOUT -- UNCHANGED C RELERR,ABSERR -- NORMAL RETURN HAS TOLERANCES UNCHANGED. IFLAG=3 C SIGNALS TOLERANCES INCREASED C IFLAG = 2 -- NORMAL RETURN. INTEGRATION REACHED TOUT C = 3 -- INTEGRATION DID NOT REACH TOUT BECAUSE ERROR C TOLERANCES TOO SMALL. RELERR , ABSERR INCREASED C APPROPRIATELY FOR CONTINUING C = 4 -- INTEGRATION DID NOT REACH TOUT BECAUSE MORE THAN C MAXNUM STEPS NEEDED C = 5 -- INTEGRATION DID NOT REACH TOUT BECAUSE EQUATIONS C APPEAR TO BE STIFF C = 6 -- INTEGRATION DID NOT REACH TOUT BECAUSE SOLUTION C VANISHED MAKING PURE RELATIVE ERROR IMPOSSIBLE. C MUST USE NON-ZERO ABSERR TO CONTINUE. C = 7 -- INVALID INPUT PARAMETERS (FATAL ERROR) C THE VALUE OF IFLAG IS RETURNED NEGATIVE WHEN THE INPUT C VALUE IS NEGATIVE AND THE INTEGRATION DOES NOT REACH TOUT , C I.E., -3, -4, -5, -6. C WORK(*),IWORK(*) -- INFORMATION GENERALLY OF NO INTEREST TO THE C USER BUT NECESSARY FOR SUBSEQUENT CALLS. C C SUBSEQUENT CALLS TO ODE -- C C SUBROUTINE ODE RETURNS WITH ALL INFORMATION NEEDED TO CONTINUE C THE INTEGRATION. IF THE INTEGRATION REACHED TOUT , THE USER NEED C ONLY DEFINE A NEW TOUT AND CALL AGAIN. IF THE INTEGRATION DID NOT C REACH TOUT AND THE USER WANTS TO CONTINUE, HE JUST CALLS AGAIN. C IN THE CASE IFLAG=6 , THE USER MUST ALSO ALTER THE ERROR CRITERION. C THE OUTPUT VALUE OF IFLAG IS THE APPROPRIATE INPUT VALUE FOR C SUBSEQUENT CALLS. THE ONLY SITUATION IN WHICH IT SHOULD BE ALTERED C IS TO STOP THE INTEGRATION INTERNALLY AT THE NEW TOUT , I.E., C CHANGE OUTPUT IFLAG=2 TO INPUT IFLAG=-2 . ERROR TOLERANCES MAY C BE CHANGED BY THE USER BEFORE CONTINUING. ALL OTHER PARAMETERS MUST C REMAIN UNCHANGED. C LOGICAL START,PHASE1,NORND DIMENSION Y(NEQN),WORK(*),IWORK(5) EXTERNAL F DATA IALPHA,IBETA,ISIG,IV,IW,IG,IPHASE,IPSI,IX,IH,IHOLD,ISTART, 1 ITOLD,IDELSN/1,13,25,38,50,62,75,76,88,89,90,91,92,93/ C IYY = 100 IWT = IYY + NEQN IP = IWT + NEQN IYP = IP + NEQN IYPOUT = IYP + NEQN IPHI = IYPOUT + NEQN IF(IABS(IFLAG) .LT. 2 .OR. IABS(IFLAG) .GT. 6) GO TO 1 START = WORK(ISTART) .GT. 0.0 PHASE1 = WORK(IPHASE) .GT. 0.0 NORND = IWORK(2) .NE. -1 1 CALL DE1(F,NEQN,Y,T,TOUT,RELERR,ABSERR,IFLAG,WORK(IYY), 1 WORK(IWT),WORK(IP),WORK(IYP),WORK(IYPOUT),WORK(IPHI), 2 WORK(IALPHA),WORK(IBETA),WORK(ISIG),WORK(IV),WORK(IW),WORK(IG), 3 PHASE1,WORK(IPSI),WORK(IX),WORK(IH),WORK(IHOLD),START, 4 WORK(ITOLD),WORK(IDELSN),IWORK(1),NORND,IWORK(3),IWORK(4), 5 IWORK(5)) WORK(ISTART) = -1.0 IF(START) WORK(ISTART) = 1.0 WORK(IPHASE) = -1.0 IF(PHASE1) WORK(IPHASE) = 1.0 IWORK(2) = -1 IF(NORND) IWORK(2) = 1 RETURN END SUBROUTINE DE1(F,NEQN,Y,T,TOUT,RELERR,ABSERR,IFLAG, 1 YY,WT,P,YP,YPOUT,PHI,ALPHA,BETA,SIG,V,W,G,PHASE1,PSI,X,H,HOLD, 2 START,TOLD,DELSGN,NS,NORND,K,KOLD,ISNOLD) C C ODE MERELY ALLOCATES STORAGE FOR DE1 TO RELIEVE THE USER OF THE C INCONVENIENCE OF A LONG CALL LIST. CONSEQUENTLY DE1 IS USED AS C DESCRIBED IN THE COMMENTS FOR ODE . C C THIS CODE IS COMPLETELY EXPLAINED AND DOCUMENTED IN THE TEXT, C COMPUTER SOLUTION OF ORDINARY DIFFERENTIAL EQUATIONS, THE INITIAL C VALUE PROBLEM BY L. F. SHAMPINE AND M. K. GORDON. C LOGICAL STIFF,CRASH,START,PHASE1,NORND DIMENSION Y(NEQN),YY(NEQN),WT(NEQN),PHI(NEQN,16),P(NEQN),YP(NEQN), 1 YPOUT(NEQN),PSI(12),ALPHA(12),BETA(12),SIG(13),V(12),W(12),G(13) EXTERNAL F C C THE CONSTANT MAXNUM IS THE MAXIMUM NUMBER OF STEPS ALLOWED IN ONE C CALL TO DE1. THE USER MAY CHANGE THIS LIMIT BY ALTERING THE C FOLLOWING STATEMENT C DATA MAXNUM/500/ C C ****** U IS A MACHINE DEPENDENT PARAMETER. U IS THE SMALLEST C POSITIVE NUMBER FOR WHICH 1.0 + U .GT. 1.0. C U = SPMPAR(1) FOURU = 4.0*U C C *** *** *** C C TEST FOR IMPROPER PARAMETERS C IF(NEQN .LT. 1) GO TO 10 IF(T .EQ. TOUT) GO TO 10 IF(RELERR .LT. 0.0 .OR. ABSERR .LT. 0.0) GO TO 10 EPS = AMAX1(RELERR,ABSERR) IF(EPS .LE. 0.0) GO TO 10 IF(IFLAG .EQ. 0) GO TO 10 ISN = ISIGN(1,IFLAG) IFLAG = IABS(IFLAG) IF(IFLAG .EQ. 1) GO TO 20 IF(T .NE. TOLD) GO TO 10 IF(IFLAG .GE. 2 .AND. IFLAG .LE. 5) GO TO 20 IF(IFLAG .EQ. 6 .AND. ABSERR .GT. 0.0) GO TO 20 10 IFLAG = 7 RETURN C C ON EACH CALL SET INTERVAL OF INTEGRATION AND COUNTER FOR NUMBER OF C STEPS. ADJUST INPUT ERROR TOLERANCES TO DEFINE WEIGHT VECTOR FOR C SUBROUTINE STEP1 C 20 DEL = TOUT - T ABSDEL = ABS(DEL) TEND = T + 10.0*DEL IF(ISN .LT. 0) TEND = TOUT NOSTEP = 0 KLE4 = 0 STIFF = .FALSE. RELEPS = RELERR/EPS ABSEPS = ABSERR/EPS IF(IFLAG .EQ. 1) GO TO 30 IF(ISNOLD .LT. 0) GO TO 30 IF(DELSGN*DEL .GT. 0.0) GO TO 50 C C ON START AND RESTART ALSO SET WORK VARIABLES X AND YY(*), STORE THE C DIRECTION OF INTEGRATION AND INITIALIZE THE STEP SIZE C 30 START = .TRUE. X = T DO 40 L = 1,NEQN 40 YY(L) = Y(L) DELSGN = SIGN(1.0,DEL) H = SIGN(AMAX1(FOURU*ABS(X),ABS(TOUT-X)),TOUT-X) C C IF ALREADY PAST OUTPUT POINT, INTERPOLATE AND RETURN C 50 IF(ABS(X-T) .LT. ABSDEL) GO TO 60 CALL INTRP(X,YY,TOUT,Y,YPOUT,NEQN,KOLD,PHI,PSI) IFLAG = 2 T = TOUT TOLD = T ISNOLD = ISN RETURN C C IF CANNOT GO PAST OUTPUT POINT AND SUFFICIENTLY CLOSE, C EXTRAPOLATE AND RETURN C 60 IF(ISN .GT. 0 .OR. ABS(TOUT-X) .GE. FOURU*ABS(X)) GO TO 80 H = TOUT - X CALL F(X,YY,YP) DO 70 L = 1,NEQN 70 Y(L) = YY(L) + H*YP(L) IFLAG = 2 T = TOUT TOLD = T ISNOLD = ISN RETURN C C TEST FOR TOO MANY STEPS C 80 IF(NOSTEP .LT. MAXNUM) GO TO 100 IFLAG = ISN*4 IF(STIFF) IFLAG = ISN*5 DO 90 L = 1,NEQN 90 Y(L) = YY(L) T = X TOLD = T ISNOLD = 1 RETURN C C LIMIT STEP SIZE, SET WEIGHT VECTOR AND TAKE A STEP C 100 H = SIGN(AMIN1(ABS(H),ABS(TEND-X)),H) DO 110 L = 1,NEQN WT(L) = RELEPS*ABS(YY(L)) + ABSEPS IF(WT(L) .LE. 0.0) GO TO 140 110 CONTINUE CALL STEP1(F,NEQN,YY,X,H,EPS,WT,START, 1 HOLD,K,KOLD,CRASH,PHI,P,YP,PSI, 2 ALPHA,BETA,SIG,V,W,G,PHASE1,NS,NORND) C C TEST FOR TOLERANCES TOO SMALL C IF(.NOT.CRASH) GO TO 130 IFLAG = ISN*3 RELERR = EPS*RELEPS ABSERR = EPS*ABSEPS DO 120 L = 1,NEQN 120 Y(L) = YY(L) T = X TOLD = T ISNOLD = 1 RETURN C C AUGMENT COUNTER ON NUMBER OF STEPS AND TEST FOR STIFFNESS C 130 NOSTEP = NOSTEP + 1 KLE4 = KLE4 + 1 IF(KOLD .GT. 4) KLE4 = 0 IF(KLE4 .GE. 50) STIFF = .TRUE. GO TO 50 C C RELATIVE ERROR CRITERION INAPPROPRIATE C 140 IFLAG = ISN*6 DO 150 L = 1,NEQN 150 Y(L) = YY(L) T = X TOLD = T ISNOLD = 1 RETURN END SUBROUTINE STEP1(F,NEQN,Y,X,H,EPS,WT,START, 1 HOLD,K,KOLD,CRASH,PHI,P,YP,PSI, 2 ALPHA,BETA,SIG,V,W,G,PHASE1,NS,NORND) C C WRITTEN BY L. F. SHAMPINE AND M. K. GORDON C C ABSTRACT C C SUBROUTINE STEP1 IS NORMALLY USED INDIRECTLY THROUGH SUBROUTINE C ODE . BECAUSE ODE SUFFICES FOR MOST PROBLEMS AND IS MUCH EASIER C TO USE, USING IT SHOULD BE CONSIDERED BEFORE USING STEP1 ALONE. C C SUBROUTINE STEP1 INTEGRATES A SYSTEM OF NEQN FIRST ORDER ORDINARY C DIFFERENTIAL EQUATIONS ONE STEP, NORMALLY FROM X TO X+H, USING A C MODIFIED DIVIDED DIFFERENCE FORM OF THE ADAMS PECE FORMULAS. LOCAL C EXTRAPOLATION IS USED TO IMPROVE ABSOLUTE STABILITY AND ACCURACY. C THE CODE ADJUSTS ITS ORDER AND STEP SIZE TO CONTROL THE LOCAL ERROR C PER UNIT STEP IN A GENERALIZED SENSE. SPECIAL DEVICES ARE INCLUDED C TO CONTROL ROUNDOFF ERROR AND TO DETECT WHEN THE USER IS REQUESTING C TOO MUCH ACCURACY. C C THIS CODE IS COMPLETELY EXPLAINED AND DOCUMENTED IN THE TEXT, C COMPUTER SOLUTION OF ORDINARY DIFFERENTIAL EQUATIONS, THE INITIAL C VALUE PROBLEM BY L. F. SHAMPINE AND M. K. GORDON. C C C THE PARAMETERS REPRESENT... C F -- SUBROUTINE TO EVALUATE DERIVATIVES C NEQN -- NUMBER OF EQUATIONS TO BE INTEGRATED C Y(*) -- SOLUTION VECTOR AT X C X -- INDEPENDENT VARIABLE C H -- APPROPRIATE STEP SIZE FOR NEXT STEP. NORMALLY DETERMINED BY C CODE C EPS -- LOCAL ERROR TOLERANCE C WT(*) -- VECTOR OF WEIGHTS FOR ERROR CRITERION C START -- LOGICAL VARIABLE SET .TRUE. FOR FIRST STEP, .FALSE. C OTHERWISE C HOLD -- STEP SIZE USED FOR LAST SUCCESSFUL STEP C K -- APPROPRIATE ORDER FOR NEXT STEP (DETERMINED BY CODE) C KOLD -- ORDER USED FOR LAST SUCCESSFUL STEP C CRASH -- LOGICAL VARIABLE SET .TRUE. WHEN NO STEP CAN BE TAKEN, C .FALSE. OTHERWISE. C YP(*) -- DERIVATIVE OF SOLUTION VECTOR AT X AFTER SUCCESSFUL C STEP C THE ARRAYS PHI, PSI ARE REQUIRED FOR THE INTERPOLATION SUBROUTINE C INTRP . THE ARRAY P IS INTERNAL TO THE CODE. THE REMAINING NINE C VARIABLES AND ARRAYS ARE INCLUDED IN THE CALL LIST ONLY TO ELIMINATE C LOCAL RETENTION OF VARIABLES BETWEEN CALLS. C C INPUT TO STEP1 C C FIRST CALL -- C C THE USER MUST PROVIDE STORAGE IN HIS CALLING PROGRAM FOR ALL ARRAYS C IN THE CALL LIST, NAMELY C C DIMENSION Y(NEQN),WT(NEQN),PHI(NEQN,16),P(NEQN),YP(NEQN),PSI(12), C 1 ALPHA(12),BETA(12),SIG(13),V(12),W(12),G(13) C C THE USER MUST ALSO DECLARE START , CRASH , PHASE1 AND NORND C LOGICAL VARIABLES AND F AN EXTERNAL SUBROUTINE, SUPPLY THE C SUBROUTINE F(X,Y,YP) TO EVALUATE C DY(I)/DX = YP(I) = F(X,Y(1),Y(2),...,Y(NEQN)) C AND INITIALIZE ONLY THE FOLLOWING PARAMETERS... C NEQN -- NUMBER OF EQUATIONS TO BE INTEGRATED C Y(*) -- VECTOR OF INITIAL VALUES OF DEPENDENT VARIABLES C X -- INITIAL VALUE OF THE INDEPENDENT VARIABLE C H -- NOMINAL STEP SIZE INDICATING DIRECTION OF INTEGRATION C AND MAXIMUM SIZE OF STEP. MUST BE VARIABLE C EPS -- LOCAL ERROR TOLERANCE PER STEP. MUST BE VARIABLE C WT(*) -- VECTOR OF NON-ZERO WEIGHTS FOR ERROR CRITERION C START -- .TRUE. C C STEP1 REQUIRES THAT THE L2 NORM OF THE VECTOR WITH COMPONENTS C LOCAL ERROR(L)/WT(L) BE LESS THAN EPS FOR A SUCCESSFUL STEP. THE C ARRAY WT ALLOWS THE USER TO SPECIFY AN ERROR TEST APPROPRIATE C FOR HIS PROBLEM. FOR EXAMPLE, C WT(L) = 1.0 SPECIFIES ABSOLUTE ERROR, C = ABS(Y(L)) ERROR RELATIVE TO THE MOST RECENT VALUE OF THE C L-TH COMPONENT OF THE SOLUTION, C = ABS(YP(L)) ERROR RELATIVE TO THE MOST RECENT VALUE OF C THE L-TH COMPONENT OF THE DERIVATIVE, C = AMAX1(WT(L),ABS(Y(L))) ERROR RELATIVE TO THE LARGEST C MAGNITUDE OF L-TH COMPONENT OBTAINED SO FAR, C = ABS(Y(L))*RELERR/EPS + ABSERR/EPS SPECIFIES A MIXED C RELATIVE-ABSOLUTE TEST WHERE RELERR IS RELATIVE C ERROR, ABSERR IS ABSOLUTE ERROR AND EPS = C AMAX1(RELERR,ABSERR) . C C SUBSEQUENT CALLS -- C C SUBROUTINE STEP1 IS DESIGNED SO THAT ALL INFORMATION NEEDED TO C CONTINUE THE INTEGRATION, INCLUDING THE STEP SIZE H AND THE ORDER C K , IS RETURNED WITH EACH STEP. WITH THE EXCEPTION OF THE STEP C SIZE, THE ERROR TOLERANCE, AND THE WEIGHTS, NONE OF THE PARAMETERS C SHOULD BE ALTERED. THE ARRAY WT MUST BE UPDATED AFTER EACH STEP C TO MAINTAIN RELATIVE ERROR TESTS LIKE THOSE ABOVE. NORMALLY THE C INTEGRATION IS CONTINUED JUST BEYOND THE DESIRED ENDPOINT AND THE C SOLUTION INTERPOLATED THERE WITH SUBROUTINE INTRP . IF IT IS C IMPOSSIBLE TO INTEGRATE BEYOND THE ENDPOINT, THE STEP SIZE MAY BE C REDUCED TO HIT THE ENDPOINT SINCE THE CODE WILL NOT TAKE A STEP C LARGER THAN THE H INPUT. CHANGING THE DIRECTION OF INTEGRATION, C I.E., THE SIGN OF H , REQUIRES THE USER SET START = .TRUE. BEFORE C CALLING STEP1 AGAIN. THIS IS THE ONLY SITUATION IN WHICH START C SHOULD BE ALTERED. C C OUTPUT FROM STEP1 C C SUCCESSFUL STEP -- C C THE SUBROUTINE RETURNS AFTER EACH SUCCESSFUL STEP WITH START AND C CRASH SET .FALSE. . X REPRESENTS THE INDEPENDENT VARIABLE C ADVANCED ONE STEP OF LENGTH HOLD FROM ITS VALUE ON INPUT AND Y C THE SOLUTION VECTOR AT THE NEW VALUE OF X . ALL OTHER PARAMETERS C REPRESENT INFORMATION CORRESPONDING TO THE NEW X NEEDED TO C CONTINUE THE INTEGRATION. C C UNSUCCESSFUL STEP -- C C WHEN THE ERROR TOLERANCE IS TOO SMALL FOR THE MACHINE PRECISION, C THE SUBROUTINE RETURNS WITHOUT TAKING A STEP AND CRASH = .TRUE. . C AN APPROPRIATE STEP SIZE AND ERROR TOLERANCE FOR CONTINUING ARE C ESTIMATED AND ALL OTHER INFORMATION IS RESTORED AS UPON INPUT C BEFORE RETURNING. TO CONTINUE WITH THE LARGER TOLERANCE, THE USER C JUST CALLS THE CODE AGAIN. A RESTART IS NEITHER REQUIRED NOR C DESIRABLE. C LOGICAL START,CRASH,PHASE1,NORND DIMENSION Y(NEQN),WT(NEQN),PHI(NEQN,16),P(NEQN),YP(NEQN),PSI(12), 1 ALPHA(12),BETA(12),SIG(13),V(12),W(12),G(13) DIMENSION TWO(13),GSTR(13) EXTERNAL F C DATA TWO(1)/2.0/, TWO(2)/4.0/, TWO(3)/8.0/, TWO(4)/16.0/, 1 TWO(5)/32.0/, TWO(6)/64.0/, TWO(7)/128.0/, TWO(8)/256.0/, 2 TWO(9)/512.0/, TWO(10)/1024.0/, TWO(11)/2048.0/, 3 TWO(12)/4096.0/, TWO(13)/8192.0/ DATA GSTR(1)/0.500/, GSTR(2)/0.0833/, GSTR(3)/0.0417/, 1 GSTR(4)/0.0264/, GSTR(5)/0.0188/, GSTR(6)/0.0143/, 2 GSTR(7)/0.0114/, GSTR(8)/0.00936/, GSTR(9)/0.00789/, 3 GSTR(10)/0.00679/, GSTR(11)/0.00592/, GSTR(12)/0.00524/, 4 GSTR(13)/0.00468/ C C ****** U IS A MACHINE DEPENDENT PARAMETER. IT IS THE SMALLEST C POSITIVE NUMBER FOR WHICH 1.0 + U .GT. 1.0. C U = SPMPAR(1) TWOU = 2.0*U FOURU = 4.0*U C C *** BEGIN BLOCK 0 *** C C CHECK IF STEP SIZE OR ERROR TOLERANCE IS TOO SMALL FOR MACHINE C PRECISION. IF FIRST STEP, INITIALIZE PHI ARRAY AND ESTIMATE A C STARTING STEP SIZE. C C *** C C IF STEP SIZE IS TOO SMALL, DETERMINE AN ACCEPTABLE ONE C CRASH = .TRUE. IF(ABS(H) .GE. FOURU*ABS(X)) GO TO 5 H = SIGN(FOURU*ABS(X),H) RETURN 5 P5EPS = 0.5*EPS C C IF ERROR TOLERANCE IS TOO SMALL, INCREASE IT TO AN ACCEPTABLE VALUE C ROUND = 0.0 DO 10 L = 1,NEQN 10 ROUND = ROUND + (Y(L)/WT(L))**2 ROUND = TWOU*SQRT(ROUND) IF(P5EPS .GE. ROUND) GO TO 15 EPS = 2.0*ROUND*(1.0 + FOURU) RETURN 15 CRASH = .FALSE. G(1) = 1.0 G(2) = 0.5 SIG(1) = 1.0 IF(.NOT.START) GO TO 99 C C INITIALIZE. COMPUTE APPROPRIATE STEP SIZE FOR FIRST STEP C CALL F(X,Y,YP) SUM = 0.0 DO 20 L = 1,NEQN PHI(L,1) = YP(L) PHI(L,2) = 0.0 20 SUM = SUM + (YP(L)/WT(L))**2 SUM = SQRT(SUM) ABSH = ABS(H) IF(EPS .LT. 16.0*SUM*H*H) ABSH = 0.25*SQRT(EPS/SUM) H = SIGN(AMAX1(ABSH,FOURU*ABS(X)),H) HOLD = 0.0 K = 1 KOLD = 0 START = .FALSE. PHASE1 = .TRUE. NORND = .TRUE. IF(P5EPS .GT. 100.0*ROUND) GO TO 99 NORND = .FALSE. DO 25 L = 1,NEQN 25 PHI(L,15) = 0.0 99 IFAIL = 0 C C *** END BLOCK 0 *** C C *** BEGIN BLOCK 1 *** C C COMPUTE COEFFICIENTS OF FORMULAS FOR THIS STEP. AVOID COMPUTING C THOSE QUANTITIES NOT CHANGED WHEN STEP SIZE IS NOT CHANGED. C C *** C 100 KP1 = K+1 KP2 = K+2 KM1 = K-1 KM2 = K-2 C C NS IS THE NUMBER OF STEPS TAKEN WITH SIZE H, INCLUDING THE CURRENT C ONE. WHEN K.LT.NS, NO COEFFICIENTS CHANGE C IF(H .NE. HOLD) NS = 0 IF (NS.LE.KOLD) NS = NS+1 NSP1 = NS+1 IF (K .LT. NS) GO TO 199 C C COMPUTE THOSE COMPONENTS OF ALPHA(*),BETA(*),PSI(*),SIG(*) WHICH C ARE CHANGED C BETA(NS) = 1.0 REALNS = NS ALPHA(NS) = 1.0/REALNS TEMP1 = H*REALNS SIG(NSP1) = 1.0 IF(K .LT. NSP1) GO TO 110 DO 105 I = NSP1,K IM1 = I-1 TEMP2 = PSI(IM1) PSI(IM1) = TEMP1 BETA(I) = BETA(IM1)*PSI(IM1)/TEMP2 TEMP1 = TEMP2 + H ALPHA(I) = H/TEMP1 REALI = I 105 SIG(I+1) = REALI*ALPHA(I)*SIG(I) 110 PSI(K) = TEMP1 C C COMPUTE COEFFICIENTS G(*) C C INITIALIZE V(*) AND SET W(*). C IF(NS .GT. 1) GO TO 120 DO 115 IQ = 1,K TEMP3 = IQ*(IQ+1) V(IQ) = 1.0/TEMP3 115 W(IQ) = V(IQ) GO TO 140 C C IF ORDER WAS RAISED, UPDATE DIAGONAL PART OF V(*) C 120 IF(K .LE. KOLD) GO TO 130 TEMP4 = K*KP1 V(K) = 1.0/TEMP4 NSM2 = NS-2 IF(NSM2 .LT. 1) GO TO 130 DO 125 J = 1,NSM2 I = K-J 125 V(I) = V(I) - ALPHA(J+1)*V(I+1) C C UPDATE V(*) AND SET W(*) C 130 LIMIT1 = KP1 - NS TEMP5 = ALPHA(NS) DO 135 IQ = 1,LIMIT1 V(IQ) = V(IQ) - TEMP5*V(IQ+1) 135 W(IQ) = V(IQ) G(NSP1) = W(1) C C COMPUTE THE G(*) IN THE WORK VECTOR W(*) C 140 NSP2 = NS + 2 IF(KP1 .LT. NSP2) GO TO 199 DO 150 I = NSP2,KP1 LIMIT2 = KP2 - I TEMP6 = ALPHA(I-1) DO 145 IQ = 1,LIMIT2 145 W(IQ) = W(IQ) - TEMP6*W(IQ+1) 150 G(I) = W(1) 199 CONTINUE C C *** END BLOCK 1 *** C C *** BEGIN BLOCK 2 *** C C PREDICT A SOLUTION P(*), EVALUATE DERIVATIVES USING PREDICTED C SOLUTION, ESTIMATE LOCAL ERROR AT ORDER K AND ERRORS AT ORDERS K, C K-1, K-2 AS IF CONSTANT STEP SIZE WERE USED. C C *** C C CHANGE PHI TO PHI STAR C IF(K .LT. NSP1) GO TO 215 DO 210 I = NSP1,K TEMP1 = BETA(I) DO 205 L = 1,NEQN 205 PHI(L,I) = TEMP1*PHI(L,I) 210 CONTINUE C C PREDICT SOLUTION AND DIFFERENCES C 215 DO 220 L = 1,NEQN PHI(L,KP2) = PHI(L,KP1) PHI(L,KP1) = 0.0 220 P(L) = 0.0 DO 230 J = 1,K I = KP1 - J IP1 = I+1 TEMP2 = G(I) DO 225 L = 1,NEQN P(L) = P(L) + TEMP2*PHI(L,I) 225 PHI(L,I) = PHI(L,I) + PHI(L,IP1) 230 CONTINUE IF(NORND) GO TO 240 DO 235 L = 1,NEQN TAU = H*P(L) - PHI(L,15) P(L) = Y(L) + TAU 235 PHI(L,16) = (P(L) - Y(L)) - TAU GO TO 250 240 DO 245 L = 1,NEQN 245 P(L) = Y(L) + H*P(L) 250 XOLD = X X = X + H ABSH = ABS(H) CALL F(X,P,YP) C C ESTIMATE ERRORS AT ORDERS K,K-1,K-2 C ERKM2 = 0.0 ERKM1 = 0.0 ERK = 0.0 DO 265 L = 1,NEQN TEMP3 = 1.0/WT(L) TEMP4 = YP(L) - PHI(L,1) IF(KM2)265,260,255 255 ERKM2 = ERKM2 + ((PHI(L,KM1)+TEMP4)*TEMP3)**2 260 ERKM1 = ERKM1 + ((PHI(L,K)+TEMP4)*TEMP3)**2 265 ERK = ERK + (TEMP4*TEMP3)**2 IF(KM2)280,275,270 270 ERKM2 = ABSH*SIG(KM1)*GSTR(KM2)*SQRT(ERKM2) 275 ERKM1 = ABSH*SIG(K)*GSTR(KM1)*SQRT(ERKM1) 280 TEMP5 = ABSH*SQRT(ERK) ERR = TEMP5*(G(K)-G(KP1)) ERK = TEMP5*SIG(KP1)*GSTR(K) KNEW = K C C TEST IF ORDER SHOULD BE LOWERED C IF(KM2)299,290,285 285 IF(AMAX1(ERKM1,ERKM2) .LE. ERK) KNEW = KM1 GO TO 299 290 IF(ERKM1 .LE. 0.5*ERK) KNEW = KM1 C C TEST IF STEP SUCCESSFUL C 299 IF(ERR .LE. EPS) GO TO 400 C C *** END BLOCK 2 *** C C *** BEGIN BLOCK 3 *** C C THE STEP IS UNSUCCESSFUL. RESTORE X, PHI(*,*), PSI(*) . C IF THIRD CONSECUTIVE FAILURE, SET ORDER TO ONE. IF STEP FAILS MORE C THAN THREE TIMES, CONSIDER AN OPTIMAL STEP SIZE. DOUBLE ERROR C TOLERANCE AND RETURN IF ESTIMATED STEP SIZE IS TOO SMALL FOR MACHINE C PRECISION. C *** C C RESTORE X, PHI(*,*) AND PSI(*) C PHASE1 = .FALSE. X = XOLD DO 310 I = 1,K TEMP1 = 1.0/BETA(I) IP1 = I+1 DO 305 L = 1,NEQN 305 PHI(L,I) = TEMP1*(PHI(L,I) - PHI(L,IP1)) 310 CONTINUE IF(K .LT. 2) GO TO 320 DO 315 I = 2,K 315 PSI(I-1) = PSI(I) - H C C ON THIRD FAILURE, SET ORDER TO ONE. THEREAFTER, USE OPTIMAL STEP C SIZE C 320 IFAIL = IFAIL + 1 TEMP2 = 0.5 IF(IFAIL - 3) 335,330,325 325 IF(P5EPS .LT. 0.25*ERK) TEMP2 = SQRT(P5EPS/ERK) 330 KNEW = 1 335 H = TEMP2*H K = KNEW IF(ABS(H) .GE. FOURU*ABS(X)) GO TO 340 CRASH = .TRUE. H = SIGN(FOURU*ABS(X),H) EPS = EPS + EPS RETURN 340 GO TO 100 C C *** END BLOCK 3 *** C C *** BEGIN BLOCK 4 *** C C THE STEP IS SUCCESSFUL. CORRECT THE PREDICTED SOLUTION, EVALUATE C THE DERIVATIVES USING THE CORRECTED SOLUTION AND UPDATE THE C DIFFERENCES. DETERMINE BEST ORDER AND STEP SIZE FOR NEXT STEP. C C *** 400 KOLD = K HOLD = H C C CORRECT AND EVALUATE C TEMP1 = H*G(KP1) IF(NORND) GO TO 410 DO 405 L = 1,NEQN RHO = TEMP1*(YP(L) - PHI(L,1)) - PHI(L,16) Y(L) = P(L) + RHO 405 PHI(L,15) = (Y(L) - P(L)) - RHO GO TO 420 410 DO 415 L = 1,NEQN 415 Y(L) = P(L) + TEMP1*(YP(L) - PHI(L,1)) 420 CALL F(X,Y,YP) C C UPDATE DIFFERENCES FOR NEXT STEP C DO 425 L = 1,NEQN PHI(L,KP1) = YP(L) - PHI(L,1) 425 PHI(L,KP2) = PHI(L,KP1) - PHI(L,KP2) DO 435 I = 1,K DO 430 L = 1,NEQN 430 PHI(L,I) = PHI(L,I) + PHI(L,KP1) 435 CONTINUE C C ESTIMATE ERROR AT ORDER K+1 UNLESS... C IN FIRST PHASE WHEN ALWAYS RAISE ORDER, C ALREADY DECIDED TO LOWER ORDER, C STEP SIZE NOT CONSTANT SO ESTIMATE UNRELIABLE C ERKP1 = 0.0 IF(KNEW .EQ. KM1 .OR. K .EQ. 12) PHASE1 = .FALSE. IF(PHASE1) GO TO 450 IF(KNEW .EQ. KM1) GO TO 455 IF(KP1 .GT. NS) GO TO 460 DO 440 L = 1,NEQN 440 ERKP1 = ERKP1 + (PHI(L,KP2)/WT(L))**2 ERKP1 = ABSH*GSTR(KP1)*SQRT(ERKP1) C C USING ESTIMATED ERROR AT ORDER K+1, DETERMINE APPROPRIATE ORDER C FOR NEXT STEP C IF(K .GT. 1) GO TO 445 IF(ERKP1 .GE. 0.5*ERK) GO TO 460 GO TO 450 445 IF(ERKM1 .LE. AMIN1(ERK,ERKP1)) GO TO 455 IF(ERKP1 .GE. ERK .OR. K .EQ. 12) GO TO 460 C C HERE ERKP1 .LT. ERK .LT. AMAX1(ERKM1,ERKM2) ELSE ORDER WOULD HAVE C BEEN LOWERED IN BLOCK 2. THUS ORDER IS TO BE RAISED C C RAISE ORDER C 450 K = KP1 ERK = ERKP1 GO TO 460 C C LOWER ORDER C 455 K = KM1 ERK = ERKM1 C C WITH NEW ORDER DETERMINE APPROPRIATE STEP SIZE FOR NEXT STEP C 460 HNEW = H + H IF(PHASE1) GO TO 465 IF(P5EPS .GE. ERK*TWO(K+1)) GO TO 465 HNEW = H IF(P5EPS .GE. ERK) GO TO 465 TEMP2 = K+1 R = (P5EPS/ERK)**(1.0/TEMP2) HNEW = ABSH*AMAX1(0.5,AMIN1(0.9,R)) HNEW = SIGN(AMAX1(HNEW,FOURU*ABS(X)),H) 465 H = HNEW RETURN C C *** END BLOCK 4 *** C END SUBROUTINE INTRP(X,Y,XOUT,YOUT,YPOUT,NEQN,KOLD,PHI,PSI) C C WRITTEN BY L. F. SHAMPINE AND M. K. GORDON C C ABSTRACT C C THE METHODS IN SUBROUTINE STEP1 APPROXIMATE THE SOLUTION NEAR X C BY A POLYNOMIAL. SUBROUTINE INTRP APPROXIMATES THE SOLUTION AT C XOUT BY EVALUATING THE POLYNOMIAL THERE. INFORMATION DEFINING THIS C POLYNOMIAL IS PASSED FROM STEP1 SO INTRP CANNOT BE USED ALONE. C C THIS CODE IS COMPLETELY EXPLAINED AND DOCUMENTED IN THE TEXT, C COMPUTER SOLUTION OF ORDINARY DIFFERENTIAL EQUATIONS, THE INITIAL C VALUE PROBLEM BY L. F. SHAMPINE AND M. K. GORDON. C C INPUT TO INTRP -- C C THE USER PROVIDES STORAGE IN THE CALLING PROGRAM FOR THE ARRAYS IN C THE CALL LIST C DIMENSION Y(NEQN),YOUT(NEQN),YPOUT(NEQN),PHI(NEQN,16),PSI(12) C AND DEFINES C XOUT -- POINT AT WHICH SOLUTION IS DESIRED. C THE REMAINING PARAMETERS ARE DEFINED IN STEP1 AND PASSED TO INTRP C FROM THAT SUBROUTINE. C C OUTPUT FROM INTRP -- C C YOUT(*) -- SOLUTION AT XOUT C YPOUT(*) -- DERIVATIVE OF SOLUTION AT XOUT C THE REMAINING PARAMETERS ARE RETURNED UNALTERED FROM THEIR INPUT C VALUES. INTEGRATION WITH STEP1 MAY BE CONTINUED. C DIMENSION Y(NEQN),YOUT(NEQN),YPOUT(NEQN),PHI(NEQN,16),PSI(12) DIMENSION G(13),W(13),RHO(13) DATA G(1)/1.0/,RHO(1)/1.0/ C HI = XOUT - X KI = KOLD + 1 KIP1 = KI + 1 C C INITIALIZE W(*) FOR COMPUTING G(*) C DO 5 I = 1,KI TEMP1 = I 5 W(I) = 1.0/TEMP1 TERM = 0.0 C C COMPUTE G(*) C DO 15 J = 2,KI JM1 = J - 1 PSIJM1 = PSI(JM1) GAMMA = (HI + TERM)/PSIJM1 ETA = HI/PSIJM1 LIMIT1 = KIP1 - J DO 10 I = 1,LIMIT1 10 W(I) = GAMMA*W(I) - ETA*W(I+1) G(J) = W(1) RHO(J) = GAMMA*RHO(JM1) 15 TERM = PSIJM1 C C INTERPOLATE C DO 20 L = 1,NEQN YPOUT(L) = 0.0 20 YOUT(L) = 0.0 DO 30 J = 1,KI I = KIP1 - J TEMP2 = G(I) TEMP3 = RHO(I) DO 25 L = 1,NEQN YOUT(L) = YOUT(L) + TEMP2*PHI(L,I) 25 YPOUT(L) = YPOUT(L) + TEMP3*PHI(L,I) 30 CONTINUE DO 35 L = 1,NEQN 35 YOUT(L) = Y(L) + HI*YOUT(L) RETURN END SUBROUTINE BRKF45 (FCN,NEQN,Y,T,TOUT,TEND,YP,RELERR,ABSERR,IFLAG, * WORK,IWORK) C C BLOCK FEHLBERG FOURTH-FIFTH ORDER RUNGE-KUTTA METHOD ADVANCING C A BLOCK OF TWO EQUAL STEPS. THE FORMULA AT THE FIRST STEP IS C 5(4) WHILE AT THE SECOND STEP IT IS 6(4). C C WRITTEN BY J.R.CASH, C DEPARTMENT OF MATHEMATICS, C IMPERIAL COLLEGE, C SOUTH KENSINGTON, LONDON SW7 2AZ, C ENGLAND. C MODIFIED BY D. HIGHAM AND A.H. MORRIS. C C THIS IS A HEAVILY REVISED VERSION OF RKF45 OF L.F. SHAMPINE AND C H.A. WATTS. C BRKF45 IS PRIMARILY DESIGNED TO SOLVE NON-STIFF AND MILDLY STIFF C INITIAL VALUE ORDINARY DIFFERENTIAL EQUATIONS WHEN DERIVATIVE C EVALUATIONS ARE INEXPENSIVE. BRKF45 USES INTERPOLATION TO PRODUCE C OUTPUT AT OFF-STEP POINTS EFFICIENTLY. BRKF45 SHOULD GENERALLY C NOT BE USED WHEN THE USER IS DEMANDING HIGH ACCURACY. IN SUCH C CASES A GOOD ADAMS CODE WILL OFTEN BE MORE EFFICIENT. C C*********************************************************************** C ABSTRACT C*********************************************************************** C C SUBROUTINE BRKF45 INTEGRATES A SYSTEM OF NEQN FIRST ORDER C ORDINARY DIFFERENTIAL EQUATIONS OF THE FORM C C DY(I)/DT = FCN(T,Y(1),Y(2),...,Y(NEQN)) C C WHERE THE Y(I) ARE KNOWN AT TIME T. C TYPICALLY THE SUBROUTINE IS USED TO INTEGRATE FROM T TO TEND C (WHILE RETURNING ANSWERS AT SPECIFIED OUTPUT POINTS TOUT), BUT C IT CAN ALSO BE USED AS A ONE-BLOCK INTEGRATOR TO ADVANCE THE C SOLUTION A SINGLE BLOCK STEP IN THE DIRECTION OF TEND. ON RETURN C THE PARAMETERS IN THE CALL LIST ARE SET FOR CONTINUING THE C INTEGRATION. THE USER HAS ONLY TO CALL BRKF45 AGAIN (AND PERHAPS C DEFINE A NEW VALUE FOR TOUT). ACTUALLY, BRKF45 IS AN INTERFACING C ROUTINE WHICH CALLS SUBROUTINE RKFC FOR THE SOLUTION. SUBROUTINE C RKFC COMPUTES AN APPROXIMATE SOLUTION OVER ONE BLOCK OF LENGTH 2H. C BRKF45 IS PARTICULARLY USEFUL WHEN OUTPUT IS REQUIRED AT MANY C OFF-STEP POINTS SINCE THE OUTPUT VALUES CAN BE OBTAINED BY C INTERPOLATION. THIS IS IN CONTRAST TO MANY OTHER RUNGE-KUTTA C PROGRAMS WHICH CHOOSE THE STEP SEQUENCE SO AS TO HIT ALL OUTPUT C POINTS EXACTLY AND SO BECOME INEFFICIENT WHEN OUTPUT IS REQUIRED C AT MANY POINTS WITHIN A STEP. C BRKF45 USES THE (5,4), (6,4) BLOCK FORMULA DESCRIBED IN C J.R. CASH, A BLOCK 6(4) RUNGE-KUTTA FORMULA FOR NON-STIFF C INITIAL VALUE PROBLEMS, ACM TRANS. MATH SOFTWARE 15 (1989), C PP. 15-28. C C THE PARAMETERS REPRESENT- C FCN -- SUBROUTINE FCN(T,Y,YP) TO EVALUATE DERIVATIVES C YP(I)=DY(I)/DT C NEQN -- NUMBER OF DIFFERENTIAL EQUATIONS TO BE INTEGRATED. C Y(*) -- APPROXIMATION TO THE SOLUTION VECTOR AT T. C T -- INDEPENDENT VARIABLE. C TOUT -- THE NEXT POINT WHERE INTERMEDIATE OUTPUT IS C REQUIRED. APPROXIMATE SOLUTIONS AT THESE POINTS C WILL BE OBAINED BY INTERPOLATION. C TEND -- END OF THE INTEGRATION RANGE. THIS WILL BE HIT EXACTLY. C YP(*) -- APPROXIMATION TO THE DERIVATIVE VECTOR DY/DT AT T. C RELERR,ABSERR -- RELATIVE AND ABSOLUTE ERROR TOLERANCES FOR C LOCAL ERROR TEST. AT THE NTH POINT OF EACH BLOCK (N=1,2) C THE CODE REQUIRES THAT C ABS(LOCAL ERROR)/N .LE. RELERR*ABS(Y) + ABSERR C FOR EACH COMPONENT OF THE LOCAL ERROR AND SOLUTION VECTORS C IFLAG -- INDICATOR FOR STATUS OF INTEGRATION. C WORK(*) -- ARRAY TO HOLD INFORMATION INTERNAL TO BRKF45 WHICH C IS NECESSARY FOR SUBSEQUENT CALLS. MUST BE DIMENSIONED C AT LEAST 6+9*NEQN C IWORK(*) -- INTEGER ARRAY USED TO HOLD INFORMATION INTERNAL TO C BRKF45 WHICH IS NECESSARY FOR SUBSEQUENT CALLS. MUST BE C DIMENSIONED AT LEAST 5 C C*********************************************************************** C FIRST CALL TO BRKF45 C*********************************************************************** C C THE USER MUST PROVIDE STORAGE IN HIS CALLING PROGRAM FOR THE ARRAYS C IN THE CALL LIST - Y(NEQN) , YP(NEQN) , WORK(6+9*NEQN) C IWORK(5), DECLARE FCN IN AN EXTERNAL STATEMENT, SUPPLY SUBROUTINE C FCN(T,Y,YP) AND INITIALIZE THE FOLLOWING PARAMETERS- C C NEQN -- NUMBER OF EQUATIONS TO BE INTEGRATED. (NEQN .GE. 1) C Y(*) -- VECTOR OF INITIAL CONDITIONS. C T -- STARTING POINT OF INTEGRATION , MUST BE A VARIABLE. C TOUT -- OUTPUT POINT AT WHICH SOLUTION, AND POSSIBLY THE C DERIVATIVE, IS DESIRED. C TEND -- END OF THE RANGE OF INTEGRATION. IF THE SOLUTION IS C REQUIRED ONLY AT TEND THEN THE USER SHOULD SET TOUT=TEND. C RELERR,ABSERR -- RELATIVE AND ABSOLUTE LOCAL ERROR TOLERANCES C WHICH MUST BE NON-NEGATIVE. RELERR MUST BE A VARIABLE WHILE C ABSERR MAY BE A CONSTANT. THE CODE SHOULD NORMALLY NOT BE C USED WITH RELATIVE ERROR CONTROL SMALLER THAN ABOUT 1.E-8, C UNLESS AN APPROPRIATE NONZERO ABSOLUTE TOLERANCE IS GIVEN. C TO AVOID LIMITING PRECISION DIFFICULTIES THE CODE REQUIRES C RELERR TO BE LARGER THAN AN INTERNALLY COMPUTED RELATIVE C ERROR PARAMETER WHICH IS MACHINE DEPENDENT. IN PARTICULAR, C PURE ABSOLUTE ERROR IS NOT PERMITTED. IF A SMALLER THAN C ALLOWABLE VALUE OF RELERR IS ATTEMPTED, BRKF45 INCREASES C RELERR APPROPRIATELY AND RETURNS CONTROL TO THE USER BEFORE C CONTINUING THE INTEGRATION. C IFLAG -- +1,-1 INDICATOR TO INITIALIZE THE CODE FOR EACH NEW C PROBLEM. NORMAL INPUT IS +1. THE USER SHOULD SET IFLAG=-1 C ONLY WHEN ONE-BLOCK INTEGRATOR CONTROL IS ESSENTIAL. IN C THIS CASE, BRKF45 ATTEMPTS TO ADVANCE THE SOLUTION A C SINGLE BLOCK IN THE DIRECTION OF TEND EACH TIME IT IS C CALLED. SINCE THIS MODE OF OPERATION RESULTS IN EXTRA C COMPUTING OVERHEAD, IT SHOULD BE AVOIDED UNLESS NEEDED. C C*********************************************************************** C OUTPUT FROM BRKF45 C*********************************************************************** C C Y(*) -- COMPUTED SOLUTION APPROXIMATION AT T. C T -- VALUE OF THE INDEPENDENT VARIABLE WHERE THE SOLUTION IS C REPORTED. C IFLAG = 2 -- SUCCESSFUL RETURN. EITHER THE INTEGRATION REACHED C T=TEND OR A SUCCESSFUL INTERPOLATION HAS BEEN C PERFORMED AT T=TOUT. IF T.EQ.TEND THEN THE C INTEGRATION IS FINISHED. IF NOT, THE CODE SHOULD BE C CALLED WITH THE NEXT VALUE OF TOUT AND WITH IFLAG=+2 C FOR NORMAL INTEGRATION OR IFLAG=-2 FOR ONE-BLOCK C INTEGRATION. C =-2 -- A SINGLE SUCCESSFUL BLOCK IN THE DIRECTION OF TEND C HAS BEEN TAKEN. NORMAL MODE FOR CONTINUING C INTEGRATION ONE BLOCK AT A TIME. C = 3 -- INTEGRATION WAS NOT COMPLETED BECAUSE RELATIVE ERROR C TOLERANCE WAS TOO SMALL. RELERR HAS BEEN INCREASED C APPROPRIATELY FOR CONTINUING. C = 4 -- INTEGRATION WAS NOT COMPLETED BECAUSE MORE THAN C 18000 DERIVATIVE EVALUATIONS WERE NEEDED. THIS C IS APPROXIMATELY 2000 BLOCKS. C = 5 -- INTEGRATION WAS NOT COMPLETED BECAUSE SOLUTION C VANISHED MAKING A PURE RELATIVE ERROR TEST C IMPOSSIBLE. MUST USE NON-ZERO ABSERR TO CONTINUE. C USING THE ONE-BLOCK INTEGRATION MODE FOR ONE BLOCK C IS A GOOD WAY TO PROCEED. C = 6 -- INTEGRATION WAS NOT COMPLETED BECAUSE REQUESTED C ACCURACY COULD NOT BE ACHIEVED USING SMALLEST C ALLOWABLE STEPSIZE. USER MUST INCREASE THE ERROR C TOLERANCE BEFORE CONTINUED INTEGRATION CAN BE C ATTEMPTED. C = 7 -- INVALID INPUT PARAMETERS C THIS INDICATOR OCCURS IF ANY OF THE FOLLOWING IS C SATISFIED - NEQN .LE. 0 C T = TEND C RELERR OR ABSERR .LT. 0. C ABS(IFLAG) .LT. 1 OR .GT. 7 C WORK(*),IWORK(*) -- INFORMATION WHICH IS USUALLY OF NO INTEREST C TO THE USER BUT NECESSARY FOR SUBSEQUENT CALLS. C WORK(1),...,WORK(NEQN) CONTAIN THE SOLUTION VECTOR C AND WORK(NEQN+1),...,WORK(2*NEQN) CONTAIN THE C DERIVATIVE VECTOR AT THE END POINT (WHICH IS ITSELF C CONTAINED IN WORK(2*NEQN+1)) OF THE BLOCK STEP JUST C COMPUTED. WORK(2*NEQN+2) CONTAINS THE STEPSIZE H C JUST USED. (THIS IS THE STEPSIZE BEING USED BY THE C INTERPOLANT OVER THIS BLOCK.) WORK(2*NEQN+3) C CONTAINS THE STEPSIZE H TO BE ATTEMPTED ON THE NEXT C BLOCK. IWORK(1) CONTAINS THE DERIVATIVE EVALUATION C COUNTER. C C*********************************************************************** C SUBSEQUENT CALLS TO BRKF45 C*********************************************************************** C C SUBROUTINE BRKF45 RETURNS WITH ALL INFORMATION NEEDED TO CONTINUE C THE INTEGRATION. AFTER THE CODE REPORTS A SUCCESSFUL SOLUTION AT C TOUT (INDICATED BY IFLAG=2), THE USER NEEDS TO DEFINE A NEW TOUT C BEFORE SIMPLY CALLING BRKF45 AGAIN TO CONTINUE IN THE NORMAL MODE. C (BUT THE USER MUST FIRST RESET IFLAG TO -2 TO CONTINUE IN THE C ONE-BLOCK INTEGRATOR MODE.) C IF THE INTEGRATION WAS NOT COMPLETED BUT THE USER STILL WANTS TO C CONTINUE (IFLAG=3,4), HE JUST CALLS BRKF45 AGAIN. IN THE CASE C IFLAG=3 THE RELERR PARAMETER HAS BEEN ADJUSTED APPROPRIATELY FOR C CONTINUING THE INTEGRATION. IN THE CASE OF IFLAG=4 THE FUNCTION C COUNTER WILL BE RESET TO 0 AND ANOTHER 18000 FUNCTION EVALUATIONS C ARE ALLOWED. C HOWEVER,IN THE CASE IFLAG=5, THE USER MUST FIRST ALTER THE ERROR C CRITERION TO USE A POSITIVE VALUE OF ABSERR BEFORE INTEGRATION CAN C PROCEED. IF HE DOES NOT,EXECUTION IS TERMINATED. C ALSO,IN THE CASE IFLAG=6, IT IS NECESSARY FOR THE USER TO RESET C IFLAG TO 2 (OR -2 WHEN THE ONE-BLOCK INTEGRATION MODE IS BEING C USED) AS WELL AS INCREASING EITHER ABSERR,RELERR OR BOTH BEFORE C THE INTEGRATION CAN BE CONTINUED. IF THIS IS NOT DONE, EXECUTION C WILL BE TERMINATED. THE OCCURRENCE OF IFLAG=6 INDICATES A TROUBLE C SPOT(SOLUTION IS CHANGING RAPIDLY,SINGULARITY MAY BE PRESENT) AND C IT OFTEN IS INADVISABLE TO CONTINUE. C IF IFLAG=7 IS OBTAINED, INTEGRATION CAN NOT BE CONTINUED UNLESS C THE INVALID INPUT PARAMETERS ARE CORRECTED. C IT SHOULD BE NOTED THAT THE ARRAYS WORK,IWORK CONTAIN INFORMATION C REQUIRED FOR SUBSEQUENT INTEGRATION. ACCORDINGLY, WORK AND IWORK C SHOULD NOT BE ALTERED. C C*********************************************************************** C USER CALLS TO THE INTERPOLANT ROUTINE EXTRA C*********************************************************************** C C SUBROUTINE EXTRA CAN ALSO BE CALLED BY THE USER, IN CONJUNCTION C WITH USAGE OF BRKF45, TO PROVIDE APPROXIMATE SOLUTIONS AT OFF-STEP C POINTS BY USE OF THE INTERPOLATING POLYNOMIAL. WHILE BRKF45 C HANDLES THE USUAL SITUATIONS, IT CAN BE HELPFUL TO THE USER TO BE C ABLE TO ACCESS THE INTERPOLANT DIRECTLY, SUCH AS WHEN DOING ROOT C FINDING. ALSO, IT IS POSSIBLE THAT THE USER MAY HAVE SOME NEED FOR C EXTRAPOLATING OUTSIDE OF THE BLOCK STEP ON WHICH THE UNDERLYING C INTERPOLANT IS BASED. BRKF45 WILL NOT DO THIS. C THE FORM OF THE USAGE CALL IS C C CALL EXTRA ( NEQN, WORK(6*NEQN+4), WORK(NEQN+1), WORK(2*NEQN+1), C WORK(2*NEQN+2), WORK(2*NEQN+4), WORK(3*NEQN+4), C WORK(4*NEQN+4), WORK(5*NEQN+4), TEX, YEX, YPEX ) C C WHERE YEX AND YPEX ARE THE SOLUTION VECTOR AND DERIVATIVE VECTOR C APPROXIMATIONS DEFINED BY THE INTERPOLANT AT THE POINT TEX, AND C WORK IS THE WORKING ARRAY SET UP BY BRKF45. THIS VERSION OF C EXTRA HAS BEEN WRITTEN BY D. HIGMAN (SEE BELOW). C C*********************************************************************** C MORE ABOUT THE INTERPOLANT ROUTINE EXTRA C*********************************************************************** C C THE FIRST DERIVATIVE APPROXIMATIONS GIVEN BY J.R. CASH HAVE BEEN C MODIFIED BY D. HIGMAN. THREE CHANGES HAVE BEEN MADE AND ARE C CLEARLY DOCUMENTED IN THE CODE. JUST SEARCH FOR THE WORD *CHANGES*. C FOR AN EXPLANATION OF THESE MODIFICATIONS SEE C REMARK ON ALGORITHM 669, BY D. HIGHAM, C ACM TRANS. MATH SOFTWARE 17, PP. 424-426. C C*********************************************************************** C LOGICAL ENDPNT,BLKOUT DIMENSION Y(NEQN),YP(NEQN),WORK(*),IWORK(5) EXTERNAL FCN C C COMPUTE INDICES FOR THE SPLITTING OF THE WORK ARRAY C KW = 1 KWP = KW + NEQN KX = KWP + NEQN KHI = KX + 1 KH = KHI + 1 KY1 = KH + 1 KY2 = KY1 + NEQN KF1 = KY2 + NEQN KF2 = KF1 + NEQN KF3 = KF2 + NEQN KF4 = KF3 + NEQN KF7 = KF4 + NEQN KSR = KF7 + NEQN KSA = KSR + 1 KT = KSA + 1 C C THE WORK SPACE TOTALS 6 + 9*NEQN . C IF (IABS(IFLAG) .EQ. 1) GO TO 10 ENDPNT = (IWORK(4) .EQ. -1) BLKOUT = (IWORK(5) .EQ. -1) C C*********************************************************************** C THIS INTERFACING ROUTINE MERELY RELIEVES THE USER OF A LONG C CALLING LIST VIA THE SPLITTING APART OF TWO WORKING STORAGE C ARRAYS. IF THIS IS NOT COMPATIBLE WITH THE USERS COMPILER, C HE MUST USE RKFC DIRECTLY. C*********************************************************************** C 10 CALL RKFC (FCN,NEQN,Y,T,TOUT,TEND,YP,RELERR,ABSERR,IFLAG,WORK(KW), * WORK(KWP),WORK(KX),WORK(KHI),WORK(KH),WORK(KY1),WORK(KY2), * WORK(KF1),WORK(KF2),WORK(KF3),WORK(KF4),WORK(KF7),WORK(KSR), * WORK(KSA),WORK(KT),IWORK(1),IWORK(2),IWORK(3),ENDPNT,BLKOUT) C IWORK(4) = 0 IF (ENDPNT) IWORK(4) = -1 IWORK(5) = 0 IF (BLKOUT) IWORK(5) = -1 C RETURN END SUBROUTINE RKFC (FCN,NEQN,Y,T,TOUT,TEND,YP,RELERR,ABSERR,IFLAG, * W,WP,X,HINT,H,Y1,Y2,F1,F2,F3,F4,F7,SAVRE,SAVAE, * TOLD,NFE,JFLAG,KFLAG,ENDPNT,BLKOUT) C C TWO STEP BLOCK RUNGE-KUTTA FEHLBERG METHOD. C A STANDARD 5(4) FORMULA IS USED AT THE FIRST POINT IN THE BLOCK C AND A 6(4) FORMULA IS USED AT THE SECOND POINT. C LOGICAL HFAILD,ENDPNT,INTERP,BLKOUT DIMENSION Y(NEQN),YP(NEQN),Y1(NEQN),Y2(NEQN),F1(NEQN),F2(NEQN), * F3(NEQN),F4(NEQN),F7(NEQN),W(NEQN),WP(NEQN) EXTERNAL FCN C C*********************************************************************** C C COEFFICIENTS DEFINING THE METHOD ... C C C2=0.25E+0 C C3=3.0E+0/8.0E+0 C C4=12.0E+0/13.0E+0 C C6=0.5E+0 C C8=3.0E+0/2.0E+0 C C9=2.0E+0 C C A21=1.0E+0/4.0E+0 C A31=3.0E+0/32.0E+0 C A32=9.0E+0/32.0E+0 C A41=1932.0E+0/2197.0E+0 C A42=-7200.0E+0/2197.0E+0 C A43=7296.0E+0/2197.0E+0 C A51=439.0E+0/216.0E+0 C A52=-8.0E+0 C A53=3680.0E+0/513.0E+0 C A54=-845.0E+0/4104.0E+0 C A61=-8.0E+0/27.0E+0 C A62=2.0E+0 C A63=-3544.0E+0/2565.0E+0 C A64=1859.0E+0/4104.0E+0 C A65=-11.0E+0/40.0E+0 C C B1B=16.0E+0/135.0E+0 C B3B=6656.0E+0/12825.0E+0 C B4B=28561.0E+0/56430.0E+0 C B5B=-9.0E+0/50.0E+0 C B6B=2.0E+0/55.0E+0 C C ERC11=1.0E+0/360.0E+0 C ERC13=-128.0E+0/4275.0E+0 C ERC14=-2197.0E+0/75240.0E+0 C ERC15=1.0E+0/50.0E+0 C DATA C2 /.250000000000000E+00/, C3 /.375000000000000E+00/, * C4 /.923076923076923E+00/, C6 /.500000000000000E+00/, * C8 /.150000000000000E+01/, C9 /.200000000000000E+01/ C DATA A21 / .250000000000000E+00/, A31 / .937500000000000E-01/, * A32 / .281250000000000E+00/, A41 / .879380974055530E+00/, * A42 /-.327719617660446E+01/, A43 / .332089212562585E+01/, * A51 / .203240740740741E+01/, A52 /-.800000000000000E+01/, * A53 / .717348927875244E+01/, A54 /-.205896686159844E+00/, * A61 /-.296296296296296E+00/, A62 / .200000000000000E+01/, * A63 /-.138167641325536E+01/, A64 / .452972709551657E+00/, * A65 /-.275000000000000E+00/ C DATA B1B /.118518518518519E+00/, B3B / .518986354775828E+00/, * B4B /.506131490342017E+00/, B5B /-.180000000000000E+00/, * B6B /.363636363636364E-01/ C DATA ERC11/ .277777777777778E-02/, ERC13/-.299415204678363E-01/, * ERC14/-.291998936735779E-01/, ERC15/ .200000000000000E-01/ C C THE ABOVE DEFINE THE COEFFICIENTS FOR BRKF45 USED TO GENERATE C THE SOLUTION AT THE FIRST BLOCK POINT. BELOW ARE ADDITIONAL C COEFFICIENTS NEEDED TO GENERATE THE SOLUTION AT THE SECOND BLOCK C POINT. C C B1=931.0E+0/6480.0E+0 C B3=315392.0E+0/1500525.0E+0 C B4=371293.0E+0/615600.0E+0 C B5=1.0E+0/50.0E+0 C B6=0.4E+0 C B7=-4.0E+0/15.0E+0 C B8=85006.0E+0/115425.0E+0 C B9=239.0E+0/1560.0E+0 C C A81=-119397029895.0E+0/151948225000.0E+0 C A82=78390.0E+0/29081.0E+0 C A83=-51517464.0E+0/132821875.0E+0 C A84=-3780749193.0E+0/1168832500.0E+0 C A85=79268193.0E+0/55925000.0E+0 C A86=-11370591.0E+0/15379375.0E+0 C A87=5670.0E+0/2237.0E+0 C C A91=23406188597.0E+0/8429231250.0E+0 C A92=-62928.0E+0/13623.0E+0 C A93=-31066887488.0E+0/5747203125.0E+0 C A94=164486461399.0E+0/8429231250.0E+0 C A95=-70336084.0E+0/11203125.0E+0 C A96=185680664.0E+0/24646875.0E+0 C A97=-3385330161.0E+0/243117160.0E+0 C A98=232648.0E+0/96795.0E+0 C DATA B1 /.143672839506173E+00/, B3 / .210187767614668E+00/, * B4 /.603140025990903E+00/, B5 / .200000000000000E-01/, * B6 /.400000000000000E+00/, B7 /-.266666666666667E+00/, * B8 /.736460905349794E+00/, B9 / .153205128205128E+00/ C DATA A81 /-.785774430040232E+00/, A82 / .269557443004023E+01/, * A83 /-.387868820553843E+00/, A84 /-.323463729234086E+01/, * A85 / .141740175234689E+01/, A86 /-.739340252773601E+00/, * A87 / .253464461332141E+01/ C DATA A91 / .277678804896947E+01/, A92 /-.461924686192469E+01/, * A93 /-.540556629238679E+01/, A94 / .195138152603181E+02/, * A95 /-.627825575453278E+01/, A96 / .753363921389629E+01/, * A97 /-.139246861924514E+02/, A98 / .240351257812904E+01/ C C NEXT WE DEFINE COEFFICIENTS FOR THE ERROR ESTIMATE FORMULA. C C B3E = 1067091077380.0E+0/1829119027671.0E+0 C B4E = 3284168845918.0E+0/21339721989495.0E+0 C B5E = 110317750789.0E+0/240996319200.0E+0- C * 4448925830089.0E+0/12329617149531.0E+0 C B6E = 1.0E+0/25.0E+0 C B7E = 0.2E+0 C B8E = 239992027043.0E+0/361494478800.0E+0 C B9E = 1273.0E+0/7800.0E+0 C B1E = 2.0E+0-B3E-B4E-B5E-B6E-B7E-B8E-B9E C C ERC21 = (B1-B1E)/2.0E+0 C ERC23 = (B3-B3E)/2.0E+0 C ERC24 = (B4-B4E)/2.0E+0 C ERC25 = (B5-B5E)/2.0E+0 C ERC26 = 9.0E+0/50.0E+0 C ERC27 = -7.0E+0/30.0E+0 C ERC28 = (B8 - B8E)/2.0E+0 C ERC29 = -0.005E+0 C DATA ERC21 /.224905375494686E-01/, ERC23 /-.186601479161668E+00/, * ERC24 /.224620349650851E+00/, ERC25 /-.384622777202128E-01/, * ERC26 /.180000000000000E+00/, ERC27 /-.233333333333333E+00/, * ERC28 /.362862030148937E-01/, ERC29 /-.500000000000000E-02/ C C*********************************************************************** C C REMIN IS A TOLERANCE THRESHOLD WHICH IS ALSO DETERMINED BY THE C INTEGRATION METHOD. IN PARTICULAR, A FIFTH ORDER METHOD WILL C GENERALLY NOT BE CAPABLE OF DELIVERING ACCURACIES NEAR LIMITING C PRECISION ON COMPUTERS WITH LONG WORDLENGTHS. THIS DOES NOT HAVE C TO BE CHANGED FOR DIFFERENT MACHINES. C DATA REMIN / 1.E-12 / C C*********************************************************************** C C THE EXPENSE IS CONTROLLED BY RESTRICTING THE NUMBER C OF FUNCTION EVALUATIONS TO BE APPROXIMATELY MAXNFE. C DATA MAXNFE / 18000 / C C*********************************************************************** C C THE COMPUTER UNIT ROUNDOFF ERROR U IS THE SMALLEST POSITIVE VALUE C REPRESENTABLE IN THE MACHINE SUCH THAT 1 + U .GT. 1. C U = SPMPAR(1) C C*********************************************************************** C C CHECK INPUT PARAMETERS C IF (NEQN .LT. 1) GO TO 500 IF (RELERR .LT. 0.0 .OR. ABSERR .LT. 0.0) GO TO 500 IF (T .EQ. TEND) GO TO 500 MFLAG = IABS(IFLAG) IF (MFLAG .NE. 1) GO TO 10 TOLD = T IF (TOUT .EQ. T) GO TO 70 IF (SIGN(1.0, TEND-T) .NE. SIGN(1.0, TOUT-T)) GO TO 500 GO TO 70 10 IF (MFLAG .EQ. 0 .OR. MFLAG .GT. 7) GO TO 500 IF (TOUT .EQ. TOLD) GO TO 20 IF (SIGN(1.0, TEND-TOLD) .NE. SIGN(1.0, TOUT-TOLD)) GO TO 500 C C CHECK CONTINUATION POSSIBILITIES C 20 IF (MFLAG .NE. 2) GO TO 30 C C IFLAG = +2 OR -2 C IF (KFLAG .LT. 3) GO TO 70 IF (KFLAG .EQ. 3) GO TO 60 IF (KFLAG .EQ. 4) GO TO 50 IF (KFLAG .EQ. 5 .AND. ABSERR .EQ. 0.0) GO TO 40 IF (KFLAG .EQ. 6 .AND. RELERR .LE. SAVRE .AND. ABSERR .LE. SAVAE) * GO TO 40 GO TO 70 C C IFLAG = 3,4,5,6 OR 7 C 30 IF (IFLAG .EQ. 3) GO TO 60 IF (IFLAG .EQ. 4) GO TO 50 IF (IFLAG .EQ. 5 .AND. ABSERR .GT. 0.0) GO TO 60 C C INTEGRATION CANNOT BE CONTINUED SINCE USER DID NOT RESPOND TO C THE INSTRUCTIONS PERTAINING TO IFLAG=5,6 OR 7 C 40 STOP C C*********************************************************************** C C RESET FUNCTION EVALUATION COUNTER C 50 NFE = 0 IF (MFLAG .EQ. 2) GO TO 70 C C RESET FLAG VALUE FROM PREVIOUS CALL C 60 IFLAG = JFLAG IF (KFLAG .EQ. 3) MFLAG = IABS(IFLAG) C C SAVE INPUT IFLAG AND SET CONTINUATION FLAG VALUE FOR SUBSEQUENT C INPUT CHECKING C 70 JFLAG = IFLAG KFLAG = 0 C C SAVE RELERR AND ABSERR FOR CHECKING INPUT ON SUBSEQUENT CALLS C SAVRE = RELERR SAVAE = ABSERR C C RESTRICT RELATIVE ERROR TOLERANCE TO BE AT LEAST AS LARGE AS C 2U+REMIN TO AVOID LIMITING PRECISION DIFFICULTIES ARISING FROM C IMPOSSIBLE ACCURACY REQUESTS. IF TOLERANCE TOO SMALL, INCREASE C AND RETURN. C RER = 2.0*U + REMIN IF (RELERR .LT. RER) GO TO 520 C U26 = 26.0*U IF (MFLAG .NE. 1) GO TO 100 C C*********************************************************************** C C INITIALIZATION -- C DEFINE INTEGRATION INDEPENDENT VARIABLE X C EVALUATE INITIAL DERIVATIVES C SET UP WORKING ARRAYS FOR INTEGRATION VARIABLES C SET COUNTER FOR FUNCTION EVALUATIONS,NFE C ESTIMATE STARTING STEPSIZE C X = T ENDPNT = .FALSE. BLKOUT = .FALSE. C A = T CALL FCN (A, Y, YP) NFE = 1 DO 80 N = 1, NEQN W(N) = Y(N) WP(N) = YP(N) 80 CONTINUE C C COMPUTE INITIAL STEPLENGTH. C DT = TOUT - T IF (DT .EQ. 0.0) DT = TEND - T H = ABS(DT) TOLN = 0.0 DO 90 K = 1, NEQN TOL = RELERR*ABS(Y(K)) + ABSERR IF (TOL .LE. 0.0) GO TO 90 TOLN = TOL YPK = ABS(YP(K)) IF (YPK*H**5 .GT. TOL) H = (TOL/YPK)**0.2 90 CONTINUE IF (TOLN .LE. 0.0) H = 0.0 H = AMAX1(H, U26*AMAX1(ABS(T),ABS(DT))) JFLAG = ISIGN(2,IFLAG) H = SIGN(H,DT) C C INITIAL STEPLENGTH NOW COMPUTED. COMPUTE FIRST SOLUTION. C C*********************************************************************** C C TO AVOID PREMATURE UNDERFLOW IN THE ERROR TOLERANCE FUNCTION, C SCALE THE ERROR TOLERANCES. C 100 SCALE = 2.0/RELERR AE = SCALE*ABSERR C C SET SAFETY FACTOR FOR STEPSIZE ADJUSTMENT, BASED ON TOLERANCES. C TOLER = AMAX1(ABSERR,RELERR) SF = 0.85 IF (TOLER .GE. 1.E-5) SF = 0.8 IF (TOLER .LE. 1.E-9) SF = 0.9 C C RESTORE INTEGRATION VARIABLE TO END OF LAST BLOCK STEP TAKEN C AND SET THE SIGN OF THE DIRECTION OF INTEGRATION. C T = X DTSIGN = SIGN(1.0, TEND-T) C C HAVE WE ALREADY INTEGRATED PAST THE PRESENT DATA OUTPUT POINT? C IF SO JUMP TO 390 AND PERFORM INTERPOLATION. C IF NOT, SEE IF WE HAVE REACHED THE END POINT OF INTEGRATION. C IF NOT, SEE IF RESULTS AT THE END OF THE BLOCK STEP NEED TO BE C REPORTED. C IF ((TOUT-T)*DTSIGN .GT. 0.0) GO TO 110 IF (TOUT .EQ. T) GO TO 510 GO TO 390 110 IF (ENDPNT) GO TO 510 IF (IFLAG .NE. -2 .OR. .NOT.BLKOUT) GO TO 150 BLKOUT = .FALSE. GO TO 400 C C*********************************************************************** C*********************************************************************** C BLOCK BY BLOCK INTEGRATION C C SEE IF WE ARE TOO CLOSE TO THE END POINT. IF SO, DO LINEAR C EXTRAPOLATION AND RETURN. C 150 IF (ABS(TEND-T) .GT. U26*ABS(T)) GO TO 190 IF (DTSIGN*(TEND-TOUT) .LE. 0.0) GO TO 160 DT = TOUT - T ENDPNT = .FALSE. T = TOUT GO TO 170 160 DT = TEND - T ENDPNT = .TRUE. T = TEND X = TEND C 170 DO 171 K = 1, NEQN Y(K) = W(K) + DT*WP(K) 171 CONTINUE CALL FCN (T, Y, YP) NFE = NFE + 1 IFLAG = 2 IF (.NOT.ENDPNT) RETURN C DO 180 N = 1,NEQN W(N) = Y(N) WP(N) = YP(N) 180 CONTINUE ENDPNT = .FALSE. RETURN C C SET SMALLEST ALLOWABLE STEPSIZE AND STEP FAILURE FLAG. C ADJUST STEPSIZE IF NECESSARY TO HIT THE END POINT OF INTEGRATION. C 190 HMIN = U26*ABS(T) HFAILD = .FALSE. HSTOP = 0.5*(TEND-T) IF (ABS(HSTOP) .GT. ABS(H)) GO TO 200 ENDPNT = .TRUE. H = HSTOP C C*********************************************************************** C CORE INTEGRATOR FOR A SINGLE BLOCK C*********************************************************************** C THE TOLERANCES HAVE BEEN SCALED TO AVOID PREMATURE UNDERFLOW IN C COMPUTING THE ERROR TOLERANCE FUNCTION ERRTOL. C TO AVOID PROBLEMS WITH ZERO CROSSINGS,RELATIVE ERROR IS MEASURED C USING THE AVERAGE OF THE MAGNITUDES OF THE SOLUTION AT THE C BEGINNING AND END POINTS OF A BLOCK. C TO DISTINGUISH THE VARIOUS ARGUMENTS, H IS NOT PERMITTED C TO BECOME SMALLER THAN 26 UNITS OF ROUNDOFF IN T. C PRACTICAL LIMITS ON THE CHANGE IN THE STEPSIZE ARE ENFORCED TO C SMOOTH THE STEPSIZE SELECTION PROCESS AND TO AVOID EXCESSIVE C CHATTERING ON PROBLEMS HAVING DISCONTINUITIES. C*********************************************************************** C C TEST NUMBER OF DERIVATIVE FUNCTION EVALUATIONS. C IF OKAY,TRY TO ADVANCE THE INTEGRATION FROM T TO T+H C 200 IF (NFE .GT. MAXNFE) GO TO 530 C C ADVANCE AN APPROXIMATE SOLUTION OVER ONE STEP OF LENGTH H C DO 210 N = 1, NEQN Y1(N) = W(N) + A21*H*WP(N) 210 CONTINUE CALL FCN (T + C2*H, Y1, F2) DO 220 N = 1, NEQN Y1(N) = W(N) + H*(A31*WP(N) + A32*F2(N)) 220 CONTINUE CALL FCN (T + C3*H, Y1, F3) DO 230 N = 1, NEQN Y1(N) = W(N) + H*(A41*WP(N) + A42*F2(N) + A43*F3(N)) 230 CONTINUE CALL FCN (T + C4*H, Y1, F4) DO 240 N = 1, NEQN Y1(N) = W(N) + H*(A51*WP(N)+A52*F2(N)+A53*F3(N)+A54*F4(N)) 240 CONTINUE CALL FCN (T + H, Y1, Y) DO 250 N = 1, NEQN Y1(N) = W(N) + H*(A61*WP(N)+A62*F2(N)+A63*F3(N)+A64*F4(N)+ * A65*Y(N)) 250 CONTINUE CALL FCN (T + C6*H, Y1, YP) NFE = NFE + 5 EEOET = 0.0 DO 270 N = 1, NEQN Y1(N) = W(N) + H*(B1B*WP(N)+B3B*F3(N)+B4B*F4(N)+B5B*Y(N)+ * B6B*YP(N)) ERRTOL = ABS(W(N)) + ABS(Y1(N)) + AE IF (ERRTOL .LE. 0.0) GO TO 540 EZ = ABS(H*(ERC11*WP(N)+ERC13*F3(N)+ERC14*F4(N)+ERC15*Y(N)+ * B6B*YP(N))) EEOET = AMAX1(EEOET,EZ/ERRTOL) 270 CONTINUE ESTTOL = EEOET*SCALE C C CHECK THE ERROR ESTIMATE. IF STEPLENGTH HAS FAILED FOR FIRST STEP C IN THE BLOCK, GO AND COMPUTE A SMALLER STEP FOR A RE-TRY. C IF (ESTTOL .GT. 1.0) GO TO 320 C C INTEGRATION SUCCESSFUL FOR FIRST STEP. NOW INTEGRATE OVER C THE SECOND STEP IN THE BLOCK C CALL FCN (T + H, Y1, F1) DO 290 N = 1, NEQN Y2(N) = W(N) + H*(A81*WP(N)+A82*F2(N)+A83*F3(N)+A84*F4(N)+ * A85*Y(N)+A86*YP(N)+A87*F1(N)) 290 CONTINUE CALL FCN (T + C8*H, Y2, F7) DO 300 N = 1, NEQN Y2(N) = W(N) + H*(A91*WP(N)+A92*F2(N)+A93*F3(N)+A94*F4(N)+ * A95*Y(N)+A96*YP(N)+A97*F1(N)+A98*F7(N)) 300 CONTINUE CALL FCN (T + C9*H, Y2, F2) NFE = NFE + 3 EEOET = 0.0 DO 310 N = 1, NEQN EE = ABS(H*(ERC21*WP(N)+ERC23*F3(N)+ERC24*F4(N)+ERC25*Y(N)+ * ERC26*YP(N)+ERC27*F1(N)+ERC28*F7(N)+ERC29*F2(N))) Y2(N) = W(N)+H*(B1*WP(N)+B3*F3(N)+B4*F4(N)+B5*Y(N)+B6*YP(N)+ * B7*F1(N)+B8*F7(N)+B9*F2(N)) ERRTOL = ABS(Y2(N)) + ABS(Y1(N)) + AE IF (ERRTOL .LE. 0.0) GO TO 540 EEOET = AMAX1(EEOET,EE/ERRTOL) 310 CONTINUE ESTTOL = EEOET*SCALE C C THE FIRST OF THE THREE CHANGES NEEDED TO MAKE THE INTERPOLANT C DERIVATIVE MORE STABLE IS THE FOLLOWING DO-LOOP. C DO 315 N = 1, NEQN Y1(N) = B1B*WP(N)+B3B*F3(N)+B4B*F4(N)+B5B*Y(N)+ * B6B*YP(N) F3(N) = B1*WP(N)+B3*F3(N)+B4*F4(N)+B5*Y(N)+B6*YP(N)+ * B7*F1(N)+B8*F7(N)+B9*F2(N) 315 CONTINUE C C CHECK THE ERROR ESTIMATE OVER THE SECOND STEP OF THE BLOCK. C IF (ESTTOL .LE. 1.0) GO TO 330 C C UNSUCCESSFUL BLOCK C REDUCE THE STEPSIZE , TRY AGAIN C THE DECREASE IS LIMITED TO A FACTOR OF ABOUT 1/10 C 320 HFAILD = .TRUE. S = 0.1 ENDPNT = .FALSE. IF (ESTTOL .LT. 1.0E+5) S = SF/ESTTOL**0.2 H = S*H IF (ABS(H) .LT. HMIN) GO TO 550 GO TO 200 C C SUCCESSFUL BLOCK. CHECK FOR NEED TO INTERPOLATE. C STORE SOLUTION AT T+2*H. C 330 T = T + 2.0*H IF (ENDPNT) T = TEND TOLD = X X = T HINT = H INTERP = .FALSE. IF ((T-TOUT)*DTSIGN .GE. 0.0) INTERP = .TRUE. C IF (INTERP) GO TO 350 DO 340 N = 1,NEQN W(N) = Y2(N) 340 CONTINUE GO TO 360 C 350 DO 351 N = 1,NEQN SWAP = W(N) W(N) = Y2(N) Y2(N) = SWAP F2(N) = WP(N) 351 CONTINUE C 360 A = T CALL FCN (A, W, WP) NFE = NFE + 1 C C CHOOSE NEXT STEPSIZE C THE INCREASE IS LIMITED TO A FACTOR OF ABOUT 10 C IF STEP FAILURE HAS JUST OCCURED, NEXT STEP IS NOT ALLOWED C TO INCREASE. C S = 10.0 IF (ESTTOL .GT. 1.E-5) S = SF/ESTTOL**0.2 IF (HFAILD) S = AMIN1(S,1.0) H = SIGN(AMAX1(S*ABS(H),HMIN), H) C C HAVE WE INTEGRATED PAST AN OUTPUT POINT? C IF SO, CALL THE INTERPOLATION ROUTINE AT T=TOUT. C IF NOT, SEE IF WE ARE AT THE END POINT OF INTEGRATION. C OTHERWISE, CHECK IF USER WANTS SOLUTIONS AT THE END OF THE BLOCK C STEP, OR ELSE CONTINUE THE INTEGRATION. C IF (INTERP) GO TO 390 IF (ENDPNT) GO TO 510 IF (IFLAG .GT. 0) GO TO 150 IFLAG = -2 GO TO 400 C C INTERPOLATE TO GET DATA AT OFF-STEP POINT AND RETURN. C C THE SECOND OF THE THREE CHANGES NEEDED TO MAKE THE INTERPOLANT C DERIVATIVE MORE STABLE IS THE NEW STATEMENT 390 GIVEN BELOW. C 390 CALL EXTRA (NEQN,F3,WP,X,HINT,Y1,Y2,F1,F2,TOUT,Y,YP) T = TOUT IF (IFLAG .LT. 0 .AND. TOUT .NE. X) BLKOUT = .TRUE. IFLAG = 2 RETURN C C RETURN WITH THE SOLUTION AT THE END OF THE LAST SUCCESSFUL C BLOCK STEP. C 400 DO 410 N = 1,NEQN Y(N) = W(N) YP(N) = WP(N) 410 CONTINUE RETURN C C INVALID INPUT, RETURN C 500 IFLAG = 7 RETURN C C WE HAVE REACHED THE ENDPOINT C 510 IFLAG = 2 ENDPNT = .FALSE. GO TO 400 C C RELATIVE ERROR TOLERANCE TOO SMALL C 520 RELERR = RER IFLAG = 3 KFLAG = 3 RETURN C C TOO MUCH WORK C 530 IFLAG = 4 KFLAG = 4 GO TO 400 C C INAPPROPRIATE ERROR TOLERANCE C 540 IFLAG = 5 KFLAG = 5 GO TO 400 C C REQUESTED ERROR UNATTAINABLE AT SMALLEST ALLOWABLE STEPSIZE C 550 IFLAG = 6 KFLAG = 6 GO TO 400 END SUBROUTINE EXTRA (NEQN,YINC2,F2,T,H,YINC1,Y,F1,F,TEX,YEX,YPEX) C C THIS VERSION OF EXTRA IS THE THIRD OF THE THREE CHANGES C NEEDED TO MAKE THE INTERPOLANT DERIVATIVE MORE STABLE. C C T IS THE INDEPENDENT VARIABLE. C Y IS THE VALUE AT T-2H. THE VALUES AT T-H AND T ARE C Y + H*YINC1 AND Y + H*YINC2 RESPECTIVELY. C F,F1 AND F2 ARE THE DERIVATIVES AT T-2H, T-H AND T. C TEX IS THE POINT WHERE THE OUTPUT IS REQUIRED. C YEX WILL HOLD THE APPROXIMATE SOLUTION AT TEX AND YPEX WILL C HOLD THE DERIVATIVE APPROXIMATION AT THIS POINT. C DIMENSION Y(NEQN),YINC1(NEQN),YINC2(NEQN),F(NEQN),F1(NEQN), * F2(NEQN),YEX(NEQN),YPEX(NEQN) C C PERFORM QUINTIC INTERPOLATION BASED ON THE VALUES C Y(N),Y(N)+H*YINC1(N),Y(N)+H*YINC2(N),F(N),F1(N),F2(N) AT THE C POINTS T-2H, T-H, T. THIS POLYNOMIAL IS EVALUATED AT THE POINT C TEX TO OBTAIN THE APPROXIMATE VALUE OF Y(TEX) AND THIS IS STORED C IN THE ARRAY YEX. THE DERIVATIVE OF THE INTERPOLATING POLYNOMIAL C IS ALSO EVALUATED AT TEX TO OBTAIN AN APPROXIMATION TO DY/DT C AT THIS POINT AND THIS APPROXIMATION IS STORED IN YPEX. C SIG = (TEX - T)/H + 2.0 DO 10 N = 1, NEQN HF = H*F(N) HF1 = H*F1(N) HF2 = H*F2(N) A1 = 2.0*(HF2 + HF) - 6.0*H*YINC2(N) + 8.0*HF1 A2 = H*YINC2(N) + 4.0*H*YINC1(N) - 4.0*HF1 - 2.0*HF A3 = HF1 + HF - 2.0*H*YINC1(N) A4 = H*YINC1(N) - HF YEX(N) = ((((A1*0.125*(SIG - 2.0) + 0.25*A2)*(SIG - 1.0) + * A3)*(SIG - 1.0) + A4)*SIG + HF)*SIG + Y(N) YPEX(N) = ((((0.625*A1*SIG + (A2 - 2.0*A1))*SIG + (1.875*A1 - * 1.5*A2 + 3.0*A3))*SIG + (0.5*(A2 - A1) - * 2.0*(A3 - A4)))*SIG + HF)/H 10 CONTINUE RETURN END SUBROUTINE RKF45 (F,NEQN,Y,T,TOUT,RELERR,ABSERR,IFLAG,WORK,IWORK) C C FEHLBERG FOURTH-FIFTH ORDER RUNGE-KUTTA METHOD C C WRITTEN BY H.A.WATTS AND L.F.SHAMPINE C SANDIA LABORATORIES C ALBUQUERQUE,NEW MEXICO C C RKF45 IS PRIMARILY DESIGNED TO SOLVE NON-STIFF AND MILDLY STIFF C DIFFERENTIAL EQUATIONS WHEN DERIVATIVE EVALUATIONS ARE INEXPENSIVE. C RKF45 SHOULD GENERALLY NOT BE USED WHEN THE USER IS DEMANDING C HIGH ACCURACY. C C ABSTRACT C C SUBROUTINE RKF45 INTEGRATES A SYSTEM OF NEQN FIRST ORDER C ORDINARY DIFFERENTIAL EQUATIONS OF THE FORM C DY(I)/DT = F(T,Y(1),Y(2),...,Y(NEQN)) C WHERE THE Y(I) ARE GIVEN AT T . C TYPICALLY THE SUBROUTINE IS USED TO INTEGRATE FROM T TO TOUT BUT IT C CAN BE USED AS A ONE-STEP INTEGRATOR TO ADVANCE THE SOLUTION A C SINGLE STEP IN THE DIRECTION OF TOUT. ON RETURN THE PARAMETERS IN C THE CALL LIST ARE SET FOR CONTINUING THE INTEGRATION. THE USER HAS C ONLY TO CALL RKF45 AGAIN (AND PERHAPS DEFINE A NEW VALUE FOR TOUT). C ACTUALLY, RKF45 IS AN INTERFACING ROUTINE WHICH CALLS SUBROUTINE C RKFS FOR THE SOLUTION. RKFS IN TURN CALLS SUBROUTINE FEHL WHICH C COMPUTES AN APPROXIMATE SOLUTION OVER ONE STEP. C C RKF45 USES THE RUNGE-KUTTA-FEHLBERG (4,5) METHOD DESCRIBED C IN THE REFERENCE C E.FEHLBERG , LOW-ORDER CLASSICAL RUNGE-KUTTA FORMULAS WITH STEPSIZE C CONTROL , NASA TR R-315 C C THE PARAMETERS REPRESENT- C F -- SUBROUTINE F(T,Y,YP) TO EVALUATE DERIVATIVES YP(I)=DY(I)/DT C NEQN -- NUMBER OF EQUATIONS TO BE INTEGRATED C Y(*) -- SOLUTION VECTOR AT T C T -- INDEPENDENT VARIABLE C TOUT -- OUTPUT POINT AT WHICH SOLUTION IS DESIRED C RELERR,ABSERR -- RELATIVE AND ABSOLUTE ERROR TOLERANCES FOR LOCAL C ERROR TEST. AT EACH STEP THE CODE REQUIRES THAT C ABS(LOCAL ERROR) .LE. RELERR*ABS(Y) + ABSERR C FOR EACH COMPONENT OF THE LOCAL ERROR AND SOLUTION VECTORS C IFLAG -- INDICATOR FOR STATUS OF INTEGRATION C WORK(*) -- ARRAY TO HOLD INFORMATION INTERNAL TO RKF45 WHICH IS C NECESSARY FOR SUBSEQUENT CALLS. MUST BE DIMENSIONED C AT LEAST 3+6*NEQN C IWORK(*) -- INTEGER ARRAY USED TO HOLD INFORMATION INTERNAL TO C RKF45 WHICH IS NECESSARY FOR SUBSEQUENT CALLS. MUST BE C DIMENSIONED AT LEAST 5 C C FIRST CALL TO RKF45 C C THE USER MUST PROVIDE STORAGE IN HIS CALLING PROGRAM FOR THE ARRAYS C IN THE CALL LIST - Y(NEQN) , WORK(3+6*NEQN) , IWORK(5) , C DECLARE F IN AN EXTERNAL STATEMENT, SUPPLY SUBROUTINE F(T,Y,YP) AND C INITIALIZE THE FOLLOWING PARAMETERS- C C NEQN -- NUMBER OF EQUATIONS TO BE INTEGRATED. (NEQN .GE. 1) C Y(*) -- VECTOR OF INITIAL CONDITIONS C T -- STARTING POINT OF INTEGRATION , MUST BE A VARIABLE C TOUT -- OUTPUT POINT AT WHICH SOLUTION IS DESIRED. C T=TOUT IS ALLOWED ON THE FIRST CALL ONLY, IN WHICH CASE C RKF45 RETURNS WITH IFLAG=2 IF CONTINUATION IS POSSIBLE. C RELERR,ABSERR -- RELATIVE AND ABSOLUTE LOCAL ERROR TOLERANCES C WHICH MUST BE NON-NEGATIVE. RELERR MUST BE A VARIABLE WHILE C ABSERR MAY BE A CONSTANT. THE CODE SHOULD NORMALLY NOT BE C USED WITH RELATIVE ERROR CONTROL SMALLER THAN ABOUT 1.E-8 . C TO AVOID LIMITING PRECISION DIFFICULTIES THE CODE REQUIRES C RELERR TO BE LARGER THAN AN INTERNALLY COMPUTED RELATIVE C ERROR PARAMETER WHICH IS MACHINE DEPENDENT. IN PARTICULAR, C PURE ABSOLUTE ERROR IS NOT PERMITTED. IF A SMALLER THAN C ALLOWABLE VALUE OF RELERR IS ATTEMPTED, RKF45 INCREASES C RELERR APPROPRIATELY AND RETURNS CONTROL TO THE USER BEFORE C CONTINUING THE INTEGRATION. C IFLAG -- +1,-1 INDICATOR TO INITIALIZE THE CODE FOR EACH NEW C PROBLEM. NORMAL INPUT IS +1. THE USER SHOULD SET IFLAG=-1 C ONLY WHEN ONE-STEP INTEGRATOR CONTROL IS ESSENTIAL. IN THIS C CASE, RKF45 ATTEMPTS TO ADVANCE THE SOLUTION A SINGLE STEP C IN THE DIRECTION OF TOUT EACH TIME IT IS CALLED. SINCE THIS C MODE OF OPERATION RESULTS IN EXTRA COMPUTING OVERHEAD, IT C SHOULD BE AVOIDED UNLESS NEEDED. C C OUTPUT FROM RKF45 C C Y(*) -- SOLUTION AT T C T -- LAST POINT REACHED IN INTEGRATION. C IFLAG = 2 -- INTEGRATION REACHED TOUT. C =-2 -- A SINGLE SUCCESSFUL STEP IN THE DIRECTION OF TOUT C HAS BEEN TAKEN. NORMAL MODE FOR CONTINUING C INTEGRATION ONE STEP AT A TIME. C = 3 -- INTEGRATION WAS NOT COMPLETED BECAUSE RELATIVE ERROR C TOLERANCE WAS TOO SMALL. RELERR HAS BEEN INCREASED C APPROPRIATELY FOR CONTINUING. C = 4 -- INTEGRATION WAS NOT COMPLETED BECAUSE MORE THAN C 3000 DERIVATIVE EVALUATIONS WERE NEEDED. THIS C IS APPROXIMATELY 500 STEPS. C = 5 -- INTEGRATION WAS NOT COMPLETED BECAUSE SOLUTION C VANISHED MAKING A PURE RELATIVE ERROR TEST C IMPOSSIBLE. MUST USE NON-ZERO ABSERR TO CONTINUE. C USING THE ONE-STEP INTEGRATION MODE FOR ONE STEP C IS A GOOD WAY TO PROCEED. C = 6 -- INTEGRATION WAS NOT COMPLETED BECAUSE REQUESTED C ACCURACY COULD NOT BE ACHIEVED USING SMALLEST C ALLOWABLE STEPSIZE. USER MUST INCREASE THE ERROR C TOLERANCE BEFORE CONTINUED INTEGRATION CAN BE C ATTEMPTED. C = 7 -- IT IS LIKELY THAT RKF45 IS INEFFICIENT FOR SOLVING C THIS PROBLEM. TOO MUCH OUTPUT IS RESTRICTING THE C NATURAL STEPSIZE CHOICE. USE THE ONE-STEP INTEGRATOR C MODE. C = 8 -- INVALID INPUT PARAMETERS C THIS INDICATOR OCCURS IF ANY OF THE FOLLOWING IS C SATISFIED - NEQN .LE. 0 C T=TOUT AND IFLAG .NE. +1 OR -1 C RELERR OR ABSERR .LT. 0. C IFLAG .EQ. 0 OR .LT. -2 OR .GT. 8 C WORK(*),IWORK(*) -- INFORMATION WHICH IS USUALLY OF NO INTEREST C TO THE USER BUT NECESSARY FOR SUBSEQUENT CALLS. C WORK(1),...,WORK(NEQN) CONTAIN THE FIRST DERIVATIVES C OF THE SOLUTION VECTOR Y AT T. WORK(NEQN+1) CONTAINS C THE STEPSIZE H TO BE ATTEMPTED ON THE NEXT STEP. C IWORK(1) CONTAINS THE DERIVATIVE EVALUATION COUNTER. C C SUBSEQUENT CALLS TO RKF45 C C SUBROUTINE RKF45 RETURNS WITH ALL INFORMATION NEEDED TO CONTINUE C INTEGRATION. IF THE INTEGRATION REACHED TOUT, THE USER NEED ONLY C DEFINE A NEW TOUT AND CALL RKF45 AGAIN. IN THE ONE-STEP INTEGRATOR C MODE (IFLAG=-2) THE USER MUST KEEP IN MIND THAT EACH STEP TAKEN IS C IN THE DIRECTION OF THE CURRENT TOUT. UPON REACHING TOUT (INDICATED C BY CHANGING IFLAG TO 2),THE USER MUST THEN DEFINE A NEW TOUT AND C RESET IFLAG TO -2 TO CONTINUE IN THE ONE-STEP INTEGRATOR MODE. C C IF THE INTEGRATION WAS NOT COMPLETED BUT THE USER STILL WANTS TO C CONTINUE (IFLAG=3,4 CASES), HE JUST CALLS RKF45 AGAIN. WITH IFLAG=3 C THE RELERR PARAMETER HAS BEEN ADJUSTED APPROPRIATELY FOR CONTINUING C THE INTEGRATION. IN THE CASE OF IFLAG=4 THE FUNCTION COUNTER WILL C BE RESET TO 0 AND ANOTHER 3000 FUNCTION EVALUATIONS ARE ALLOWED. C C HOWEVER,IN THE CASE IFLAG=5, THE USER MUST FIRST ALTER THE ERROR C CRITERION TO USE A POSITIVE VALUE OF ABSERR BEFORE INTEGRATION CAN C PROCEED. IF HE DOES NOT,EXECUTION IS TERMINATED. C C ALSO,IN THE CASE IFLAG=6, IT IS NECESSARY FOR THE USER TO RESET C IFLAG TO 2 (OR -2 WHEN THE ONE-STEP INTEGRATION MODE IS BEING USED) C AS WELL AS INCREASING EITHER ABSERR,RELERR OR BOTH BEFORE THE C INTEGRATION CAN BE CONTINUED. IF THIS IS NOT DONE, EXECUTION WILL C BE TERMINATED. THE OCCURRENCE OF IFLAG=6 INDICATES A TROUBLE SPOT C (SOLUTION IS CHANGING RAPIDLY,SINGULARITY MAY BE PRESENT) AND IT C OFTEN IS INADVISABLE TO CONTINUE. C C IF IFLAG=7 IS ENCOUNTERED, THE USER SHOULD USE THE ONE-STEP MODE C OR SWITCH TO ANOTHER ROUTINE. IF THE USER INSISTS UPON CONTINUING C THE INTEGRATION WITH RKF45, THEN HE MUST RESET IFLAG TO 2 OR -2 C BEFORE RECALLING RKF45. OTHERWISE, EXECUTION WILL BE TERMINATED. C C IF IFLAG=8 IS OBTAINED, INTEGRATION CANNOT BE CONTINUED UNLESS C THE INVALID INPUT PARAMETERS ARE CORRECTED. C C IT SHOULD BE NOTED THAT THE ARRAYS WORK,IWORK CONTAIN INFORMATION C REQUIRED FOR SUBSEQUENT INTEGRATION. ACCORDINGLY, WORK AND IWORK C SHOULD NOT BE ALTERED. C INTEGER NEQN,IFLAG,IWORK(5) REAL Y(NEQN),T,TOUT,RELERR,ABSERR,WORK(*) C EXTERNAL F C INTEGER K1,K2,K3,K4,K5,K6,K1M C C COMPUTE INDICES FOR THE SPLITTING OF THE WORK ARRAY C K1M=NEQN+1 K1=K1M+1 K2=K1+NEQN K3=K2+NEQN K4=K3+NEQN K5=K4+NEQN K6=K5+NEQN C C THIS INTERFACING ROUTINE MERELY RELIEVES THE USER OF A LONG C CALLING LIST VIA THE SPLITTING APART OF TWO WORKING STORAGE C ARRAYS. IF THIS IS NOT COMPATIBLE WITH THE USERS COMPILER, C HE MUST USE RKFS DIRECTLY. C CALL RKFS(F,NEQN,Y,T,TOUT,RELERR,ABSERR,IFLAG,WORK(1),WORK(K1M), 1 WORK(K1),WORK(K2),WORK(K3),WORK(K4),WORK(K5),WORK(K6), 2 WORK(K6+1),IWORK(1),IWORK(2),IWORK(3),IWORK(4),IWORK(5)) C RETURN END SUBROUTINE RKFS(F,NEQN,Y,T,TOUT,RELERR,ABSERR,IFLAG,YP,H,F1,F2,F3, 1 F4,F5,SAVRE,SAVAE,NFE,KOP,INIT,JFLAG,KFLAG) C C C RKFS INTEGRATES A SYSTEM OF FIRST ORDER ORDINARY DIFFERENTIAL C EQUATIONS AS DESCRIBED IN THE COMMENTS FOR RKF45 . C THE ARRAYS YP,F1,F2,F3,F4,AND F5 (OF DIMENSION AT LEAST NEQN) AND C THE VARIABLES H,SAVRE,SAVAE,NFE,KOP,INIT,JFLAG,AND KFLAG ARE USED C INTERNALLY BY THE CODE AND APPEAR IN THE CALL LIST TO ELIMINATE C LOCAL RETENTION OF VARIABLES BETWEEN CALLS. ACCORDINGLY, THEY C SHOULD NOT BE ALTERED. ITEMS OF POSSIBLE INTEREST ARE C YP - DERIVATIVE OF SOLUTION VECTOR AT T C H - AN APPROPRIATE STEPSIZE TO BE USED FOR THE NEXT STEP C NFE- COUNTER ON THE NUMBER OF DERIVATIVE FUNCTION EVALUATIONS C LOGICAL HFAILD,OUTPUT C INTEGER NEQN,IFLAG,NFE,KOP,INIT,JFLAG,KFLAG REAL Y(NEQN),T,TOUT,RELERR,ABSERR,H,YP(NEQN), 1 F1(NEQN),F2(NEQN),F3(NEQN),F4(NEQN),F5(NEQN),SAVRE, 2 SAVAE C EXTERNAL F C REAL A,AE,DT,EE,EEOET,ESTTOL,ET,HMIN,REMIN,RER,S, 1 SCALE,TOL,TOLN,U26,EPS,YPK,SPMPAR C INTEGER K,MAXNFE,MFLAG C C REMIN IS THE MINIMUM ACCEPTABLE VALUE OF RELERR. ATTEMPTS C TO OBTAIN HIGHER ACCURACY WITH THIS SUBROUTINE ARE USUALLY C VERY EXPENSIVE AND OFTEN UNSUCCESSFUL. C DATA REMIN/1.E-12/ C C THE EXPENSE IS CONTROLLED BY RESTRICTING THE NUMBER C OF FUNCTION EVALUATIONS TO BE APPROXIMATELY MAXNFE. C AS SET, THIS CORRESPONDS TO ABOUT 500 STEPS. C DATA MAXNFE/3000/ C C CHECK INPUT PARAMETERS C IF (NEQN .LT. 1) GO TO 10 IF (RELERR .LT. 0.0 .OR. ABSERR .LT. 0.0) GO TO 10 MFLAG = IABS(IFLAG) IF (MFLAG .EQ. 0 .OR. MFLAG .GT. 8) GO TO 10 C C COMPUTE THE RELATIVE MACHINE PRECISION C EPS = SPMPAR(1) U26 = 26.0*EPS IF (MFLAG .NE. 1) GO TO 20 GO TO 50 C C INVALID INPUT C 10 IFLAG = 8 RETURN C C CHECK CONTINUATION POSSIBILITIES C 20 IF (T .EQ. TOUT .AND. KFLAG .NE. 3) GO TO 10 IF (MFLAG .NE. 2) GO TO 25 C C IFLAG = +2 OR -2 C IF (KFLAG .EQ. 3) GO TO 45 IF (INIT .EQ. 0) GO TO 45 IF (KFLAG .EQ. 4) GO TO 40 IF ((KFLAG .EQ. 5) .AND. (ABSERR .EQ. 0.0)) GO TO 30 IF ((KFLAG .EQ. 6) .AND. (RELERR .LE. SAVRE) .AND. 1 (ABSERR .LE. SAVAE)) GO TO 30 GO TO 50 C C IFLAG = 3,4,5,6,7 OR 8 C 25 IF (IFLAG .EQ. 3) GO TO 45 IF (IFLAG .EQ. 4) GO TO 40 IF (IFLAG .EQ. 5 .AND. ABSERR .GT. 0.0) GO TO 45 C C INTEGRATION CANNOT BE CONTINUED SINCE USER DID NOT RESPOND TO C THE INSTRUCTIONS PERTAINING TO IFLAG=5,6,7 OR 8 C 30 STOP C C RESET FUNCTION EVALUATION COUNTER C 40 NFE = 0 IF (MFLAG .EQ. 2) GO TO 50 C C RESET FLAG VALUE FROM PREVIOUS CALL C 45 IFLAG = JFLAG IF (KFLAG .EQ. 3) MFLAG = IABS(IFLAG) C C SAVE INPUT IFLAG AND SET CONTINUATION FLAG VALUE FOR SUBSEQUENT C INPUT CHECKING C 50 JFLAG = IFLAG KFLAG = 0 C C SAVE RELERR AND ABSERR FOR CHECKING INPUT ON SUBSEQUENT CALLS C SAVRE = RELERR SAVAE = ABSERR C C RESTRICT RELATIVE ERROR TOLERANCE TO BE AT LEAST AS LARGE AS C 2*EPS+REMIN TO AVOID LIMITING PRECISION DIFFICULTIES ARISING C FROM IMPOSSIBLE ACCURACY REQUESTS C RER = 2.0*EPS + REMIN IF (RELERR .GE. RER) GO TO 55 C C RELATIVE ERROR TOLERANCE TOO SMALL C RELERR = RER IFLAG = 3 KFLAG = 3 RETURN C 55 DT = TOUT - T C IF (MFLAG .EQ. 1) GO TO 60 IF (INIT .EQ. 0) GO TO 65 GO TO 80 C C INITIALIZATION -- C SET INITIALIZATION COMPLETION INDICATOR,INIT C SET INDICATOR FOR TOO MANY OUTPUT POINTS,KOP C EVALUATE INITIAL DERIVATIVES C SET COUNTER FOR FUNCTION EVALUATIONS,NFE C ESTIMATE STARTING STEPSIZE C 60 INIT = 0 KOP = 0 C A = T CALL F(A,Y,YP) NFE = 1 IF (T .NE. TOUT) GO TO 65 IFLAG = 2 RETURN C 65 INIT = 1 H = ABS(DT) TOLN = 0.0 DO 70 K = 1,NEQN TOL = RELERR*ABS(Y(K)) + ABSERR IF (TOL .LE. 0.) GO TO 70 TOLN = TOL YPK = ABS(YP(K)) IF (YPK*H**5 .GT. TOL) H=(TOL/YPK)**0.2 70 CONTINUE IF (TOLN .LE. 0.0) H=0.0 H = AMAX1(H,U26*AMAX1(ABS(T),ABS(DT))) JFLAG = ISIGN(2,IFLAG) C C SET STEPSIZE FOR INTEGRATION IN THE DIRECTION FROM T TO TOUT C 80 H = SIGN(H,DT) C C TEST TO SEE IF RKF45 IS BEING SEVERELY IMPACTED BY TOO MANY C OUTPUT POINTS C IF (ABS(H) .GE. 2.0*ABS(DT)) KOP = KOP + 1 IF (KOP .NE. 100) GO TO 85 C C UNNECESSARY FREQUENCY OF OUTPUT KOP = 0 IFLAG = 7 RETURN C 85 IF (ABS(DT) .GT. U26*ABS(T)) GO TO 95 C C IF TOO CLOSE TO OUTPUT POINT,EXTRAPOLATE AND RETURN C DO 90 K=1,NEQN 90 Y(K) = Y(K) + DT*YP(K) A = TOUT CALL F(A,Y,YP) NFE = NFE + 1 GO TO 300 C C C INITIALIZE OUTPUT POINT INDICATOR C 95 OUTPUT = .FALSE. C C TO AVOID PREMATURE UNDERFLOW IN THE ERROR TOLERANCE FUNCTION, C SCALE THE ERROR TOLERANCES C SCALE = 2.0/RELERR AE = SCALE*ABSERR C C STEP BY STEP INTEGRATION C 100 HFAILD = .FALSE. C C SET SMALLEST ALLOWABLE STEPSIZE C HMIN = U26*ABS(T) C C ADJUST STEPSIZE IF NECESSARY TO HIT THE OUTPUT POINT. C LOOK AHEAD TWO STEPS TO AVOID DRASTIC CHANGES IN THE STEPSIZE AND C THUS LESSEN THE IMPACT OF OUTPUT POINTS ON THE CODE. C DT = TOUT - T IF (ABS(DT) .GE. 2.0*ABS(H)) GO TO 200 IF (ABS(DT) .GT. ABS(H)) GO TO 150 C C THE NEXT SUCCESSFUL STEP WILL COMPLETE THE INTEGRATION TO THE C OUTPUT POINT C OUTPUT = .TRUE. H = DT GO TO 200 C 150 H=0.5*DT C C C CORE INTEGRATOR FOR TAKING A SINGLE STEP C C THE TOLERANCES HAVE BEEN SCALED TO AVOID PREMATURE UNDERFLOW IN C COMPUTING THE ERROR TOLERANCE FUNCTION ET. C TO AVOID PROBLEMS WITH ZERO CROSSINGS,RELATIVE ERROR IS MEASURED C USING THE AVERAGE OF THE MAGNITUDES OF THE SOLUTION AT THE C BEGINNING AND END OF A STEP. C THE ERROR ESTIMATE FORMULA HAS BEEN GROUPED TO CONTROL LOSS OF C SIGNIFICANCE. C TO DISTINGUISH THE VARIOUS ARGUMENTS, H IS NOT PERMITTED C TO BECOME SMALLER THAN 26 UNITS OF ROUNDOFF IN T. C PRACTICAL LIMITS ON THE CHANGE IN THE STEPSIZE ARE ENFORCED TO C SMOOTH THE STEPSIZE SELECTION PROCESS AND TO AVOID EXCESSIVE C CHATTERING ON PROBLEMS HAVING DISCONTINUITIES. C TO PREVENT UNNECESSARY FAILURES, THE CODE USES 9/10 THE STEPSIZE C IT ESTIMATES WILL SUCCEED. C AFTER A STEP FAILURE, THE STEPSIZE IS NOT ALLOWED TO INCREASE FOR C THE NEXT ATTEMPTED STEP. THIS MAKES THE CODE MORE EFFICIENT ON C PROBLEMS HAVING DISCONTINUITIES AND MORE EFFECTIVE IN GENERAL C SINCE LOCAL EXTRAPOLATION IS BEING USED AND EXTRA CAUTION SEEMS C WARRANTED. C C TEST NUMBER OF DERIVATIVE FUNCTION EVALUATIONS. C IF OKAY,TRY TO ADVANCE THE INTEGRATION FROM T TO T+H C 200 IF (NFE .LE. MAXNFE) GO TO 220 C C TOO MUCH WORK C IFLAG = 4 KFLAG = 4 RETURN C C ADVANCE AN APPROXIMATE SOLUTION OVER ONE STEP OF LENGTH H C 220 CALL FEHL (F,NEQN,Y,T,H,YP,F1,F2,F3,F4,F5,F1) NFE = NFE + 5 C C COMPUTE AND TEST ALLOWABLE TOLERANCES VERSUS LOCAL ERROR ESTIMATES C AND REMOVE SCALING OF TOLERANCES. NOTE THAT RELATIVE ERROR IS C MEASURED WITH RESPECT TO THE AVERAGE OF THE MAGNITUDES OF THE C SOLUTION AT THE BEGINNING AND END OF THE STEP. C EEOET = 0.0 DO 250 K = 1,NEQN ET = ABS(Y(K)) + ABS(F1(K)) + AE IF (ET .GT. 0.0) GO TO 240 C C INAPPROPRIATE ERROR TOLERANCE C IFLAG = 5 RETURN C 240 EE = ABS((-2090.0*YP(K)+(21970.0*F3(K)-15048.0*F4(K)))+ 1 (22528.0*F2(K)-27360.0*F5(K))) 250 EEOET = AMAX1(EEOET,EE/ET) C ESTTOL = ABS(H)*EEOET*SCALE/752400.0 IF (ESTTOL .LE. 1.0) GO TO 260 C C UNSUCCESSFUL STEP C REDUCE THE STEPSIZE , TRY AGAIN C THE DECREASE IS LIMITED TO A FACTOR OF 1/10 C HFAILD = .TRUE. OUTPUT = .FALSE. S = 0.1 IF (ESTTOL .LT. 59049.0) S = 0.9/ESTTOL**0.2 H = S*H IF (ABS(H) .GT. HMIN) GO TO 200 C C REQUESTED ERROR UNATTAINABLE AT SMALLEST ALLOWABLE STEPSIZE C IFLAG = 6 KFLAG = 6 RETURN C C SUCCESSFUL STEP C STORE SOLUTION AT T+H C AND EVALUATE DERIVATIVES THERE C 260 T = T + H DO 270 K = 1,NEQN 270 Y(K) = F1(K) A = T CALL F(A,Y,YP) NFE = NFE + 1 C C CHOOSE NEXT STEPSIZE C THE INCREASE IS LIMITED TO A FACTOR OF 5 C IF STEP FAILURE HAS JUST OCCURRED, NEXT C STEPSIZE IS NOT ALLOWED TO INCREASE C S=5.0 IF (ESTTOL .GT. 1.889568E-4) S=0.9/ESTTOL**0.2 IF (HFAILD) S=AMIN1(S,1.0) H=SIGN(AMAX1(S*ABS(H),HMIN),H) C C END OF CORE INTEGRATOR C C C SHOULD WE TAKE ANOTHER STEP C IF (OUTPUT) GO TO 300 IF (IFLAG .GT. 0) GO TO 100 C C INTEGRATION SUCCESSFULLY COMPLETED C C ONE-STEP MODE C IFLAG = -2 RETURN C C INTERVAL MODE C 300 T = TOUT IFLAG = 2 RETURN END SUBROUTINE FEHL(F,NEQN,Y,T,H,YP,F1,F2,F3,F4,F5,S) C C FEHLBERG FOURTH-FIFTH ORDER RUNGE-KUTTA METHOD C C FEHL INTEGRATES A SYSTEM OF NEQN FIRST ORDER C ORDINARY DIFFERENTIAL EQUATIONS OF THE FORM C DY(I)/DT=F(T,Y(1),---,Y(NEQN)) C WHERE THE INITIAL VALUES Y(I) AND THE INITIAL DERIVATIVES C YP(I) ARE SPECIFIED AT THE STARTING POINT T. FEHL ADVANCES C THE SOLUTION OVER THE FIXED STEP H AND RETURNS C THE FIFTH ORDER (SIXTH ORDER ACCURATE LOCALLY) SOLUTION C APPROXIMATION AT T+H IN ARRAY S(I). C F1,---,F5 ARE ARRAYS OF DIMENSION NEQN WHICH ARE NEEDED C FOR INTERNAL STORAGE. C THE FORMULAS HAVE BEEN GROUPED TO CONTROL LOSS OF SIGNIFICANCE. C FEHL SHOULD BE CALLED WITH AN H NOT SMALLER THAN 13 UNITS OF C ROUNDOFF IN T SO THAT THE VARIOUS INDEPENDENT ARGUMENTS CAN BE C DISTINGUISHED. C C INTEGER NEQN REAL Y(NEQN),T,H,YP(NEQN),F1(NEQN),F2(NEQN), 1 F3(NEQN),F4(NEQN),F5(NEQN),S(NEQN) C REAL CH INTEGER K EXTERNAL F C CH=H/4.0 DO 221 K=1,NEQN 221 F5(K)=Y(K)+CH*YP(K) CALL F(T+CH,F5,F1) C CH=3.0*H/32.0 DO 222 K=1,NEQN 222 F5(K)=Y(K)+CH*(YP(K)+3.0*F1(K)) CALL F(T+3.0*H/8.0,F5,F2) C CH=H/2197.0 DO 223 K=1,NEQN 223 F5(K)=Y(K)+CH*(1932.0*YP(K)+(7296.0*F2(K)-7200.0*F1(K))) CALL F(T+12.0*H/13.0,F5,F3) C CH=H/4104.0 DO 224 K=1,NEQN 224 F5(K)=Y(K)+CH*((8341.0*YP(K)-845.0*F3(K))+ 1 (29440.0*F2(K)-32832.0*F1(K))) CALL F(T+H,F5,F4) C CH=H/20520.0 DO 225 K=1,NEQN 225 F1(K)=Y(K)+CH*((-6080.0*YP(K)+(9295.0*F3(K)- 1 5643.0*F4(K)))+(41040.0*F1(K)-28352.0*F2(K))) CALL F(T+H/2.0,F1,F5) C C COMPUTE APPROXIMATE SOLUTION AT T+H C CH=H/7618050.0 DO 230 K=1,NEQN 230 S(K)=Y(K)+CH*((902880.0*YP(K)+(3855735.0*F3(K)- 1 1371249.0*F4(K)))+(3953664.0*F2(K)+ 2 277020.0*F5(K))) C RETURN END SUBROUTINE GERK(F,NEQN,Y,T,TOUT,RELERR,ABSERR,IFLAG,GERROR, 1 WORK,IWORK) C C FEHLBERG FOURTH(FIFTH) ORDER RUNGE-KUTTA METHOD WITH C GLOBAL ERROR ASSESSMENT C C WRITTEN BY H.A.WATTS AND L.F.SHAMPINE C SANDIA LABORATORIES C C GERK IS DESIGNED TO SOLVE SYSTEMS OF DIFFERENTIAL EQUATIONS WHEN C IT IS IMPORTANT TO HAVE A READILY AVAILABLE GLOBAL ERROR ESTIMATE. C PARALLEL INTEGRATION IS PERFORMED TO YIELD TWO SOLUTIONS ON C DIFFERENT MESH SPACINGS AND GLOBAL EXTRAPOLATION IS APPLIED TO C PROVIDE AN ESTIMATE OF THE GLOBAL ERROR IN THE MORE ACCURATE C SOLUTION. C C*********************************************************************** C ABSTRACT C*********************************************************************** C C SUBROUTINE GERK INTEGRATES A SYSTEM OF NEQN FIRST ORDER C ORDINARY DIFFERENTIAL EQUATIONS OF THE FORM C DY(I)/DT = F(T,Y(1),Y(2),...,Y(NEQN)) C WHERE THE Y(I) ARE GIVEN AT T . C TYPICALLY THE SUBROUTINE IS USED TO INTEGRATE FROM T TO TOUT BUT IT C CAN BE USED AS A ONE-STEP INTEGRATOR TO ADVANCE THE SOLUTION A C SINGLE STEP IN THE DIRECTION OF TOUT. ON RETURN,AN ESTIMATE OF THE C GLOBAL ERROR IN THE SOLUTION AT T IS PROVIDED AND THE PARAMETERS IN C THE CALL LIST ARE SET FOR CONTINUING THE INTEGRATION. THE USER HAS C ONLY TO CALL GERK AGAIN (AND PERHAPS DEFINE A NEW VALUE FOR TOUT). C ACTUALLY, GERK IS MERELY AN INTERFACING ROUTINE WHICH ALLOCATES C VIRTUAL STORAGE IN THE ARRAYS WORK,IWORK AND CALLS SUBROUTINE GERKS C FOR THE SOLUTION. GERKS IN TURN CALLS SUBROUTINE FEHL WHICH C COMPUTES AN APPROXIMATE SOLUTION OVER ONE STEP. C C GERK USES THE RUNGE-KUTTA-FEHLBERG (4,5) METHOD DESCRIBED C IN THE REFERENCE C E.FEHLBERG , LOW-ORDER CLASSICAL RUNGE-KUTTA FORMULAS WITH STEPSIZE C CONTROL , NASA TR R-315 C C C THE PARAMETERS REPRESENT- C F -- SUBROUTINE F(T,Y,YP) TO EVALUATE DERIVATIVES YP(I)=DY(I)/DT C NEQN -- NUMBER OF EQUATIONS TO BE INTEGRATED C Y(*) -- SOLUTION VECTOR AT T C T -- INDEPENDENT VARIABLE C TOUT -- OUTPUT POINT AT WHICH SOLUTION IS DESIRED C RELERR,ABSERR -- RELATIVE AND ABSOLUTE ERROR TOLERANCES FOR LOCAL C ERROR TEST. AT EACH STEP THE CODE REQUIRES THAT C ABS(LOCAL ERROR) .LE. RELERR*ABS(Y) + ABSERR C FOR EACH COMPONENT OF THE LOCAL ERROR AND SOLUTION VECTORS C IFLAG -- INDICATOR FOR STATUS OF INTEGRATION C GERROR(*) -- VECTOR WHICH ESTIMATES THE GLOBAL ERROR AT T. THAT C IS, GERROR(I) APPROXIMATES Y(I)-TRUE SOLUTION(I). C WORK(*) -- ARRAY TO HOLD INFORMATION INTERNAL TO GERK WHICH IS C NECESSARY FOR SUBSEQUENT CALLS. MUST BE DIMENSIONED C AT LEAST 3+8*NEQN. C IWORK(*) -- INTEGER ARRAY USED TO HOLD INFORMATION INTERNAL TO C GERK WHICH IS NECESSARY FOR SUBSEQUENT CALLS. MUST BE C DIMENSIONED AT LEAST 5. C C C*********************************************************************** C FIRST CALL TO GERK C*********************************************************************** C C THE USER MUST PROVIDE STORAGE IN HIS CALLING PROGRAM FOR THE ARRAYS C IN THE CALL LIST - Y(NEQN) , WORK(3+8*NEQN) , IWORK(5) , C DECLARE F IN AN EXTERNAL STATEMENT, SUPPLY SUBROUTINE F(T,Y,YP) AND C INITIALIZE THE FOLLOWING PARAMETERS- C C NEQN -- NUMBER OF EQUATIONS TO BE INTEGRATED. (NEQN .GE. 1) C Y(*) -- VECTOR OF INITIAL CONDITIONS C T -- STARTING POINT OF INTEGRATION , MUST BE A VARIABLE C TOUT -- OUTPUT POINT AT WHICH SOLUTION IS DESIRED. C T=TOUT IS ALLOWED ON THE FIRST CALL ONLY,IN WHICH CASE GERK C RETURNS WITH IFLAG=2 IF CONTINUATION IS POSSIBLE. C RELERR,ABSERR -- RELATIVE AND ABSOLUTE LOCAL ERROR TOLERANCES C WHICH MUST BE NON-NEGATIVE BUT MAY BE CONSTANTS. WE CAN C USUALLY EXPECT THE GLOBAL ERRORS TO BE SOMEWHAT SMALLER C THAN THE REQUESTED LOCAL ERROR TOLERANCES. TO AVOID C LIMITING PRECISION DIFFICULTIES THE CODE ALWAYS USES THE C LARGER OF RELERR AND AN INTERNAL RELATIVE ERROR PARAMETER C WHICH IS MACHINE DEPENDENT. C IFLAG -- +1,-1 INDICATOR TO INITIALIZE THE CODE FOR EACH NEW C PROBLEM. NORMAL INPUT IS +1. THE USER SHOULD SET IFLAG=-1 C ONLY WHEN ONE-STEP INTEGRATOR CONTROL IS ESSENTIAL. IN THIS C CASE, GERK ATTEMPTS TO ADVANCE THE SOLUTION A SINGLE STEP C IN THE DIRECTION OF TOUT EACH TIME IT IS CALLED. SINCE THIS C MODE OF OPERATION RESULTS IN EXTRA COMPUTING OVERHEAD, IT C SHOULD BE AVOIDED UNLESS NEEDED. C C C*********************************************************************** C OUTPUT FROM GERK C*********************************************************************** C C Y(*) -- SOLUTION AT T C T -- LAST POINT REACHED IN INTEGRATION. C IFLAG = 2 -- INTEGRATION REACHED TOUT.INDICATES SUCCESSFUL RETURN C AND IS THE NORMAL MODE FOR CONTINUING INTEGRATION. C =-2 -- A SINGLE SUCCESSFUL STEP IN THE DIRECTION OF TOUT C HAS BEEN TAKEN. NORMAL MODE FOR CONTINUING C INTEGRATION ONE STEP AT A TIME. C = 3 -- INTEGRATION WAS NOT COMPLETED BECAUSE MORE THAN C 9000 DERIVATIVE EVALUATIONS WERE NEEDED. THIS C IS APPROXIMATELY 500 STEPS. C = 4 -- INTEGRATION WAS NOT COMPLETED BECAUSE SOLUTION C VANISHED MAKING A PURE RELATIVE ERROR TEST C IMPOSSIBLE. MUST USE NON-ZERO ABSERR TO CONTINUE. C USING THE ONE-STEP INTEGRATION MODE FOR ONE STEP C IS A GOOD WAY TO PROCEED. C = 5 -- INTEGRATION WAS NOT COMPLETED BECAUSE REQUESTED C ACCURACY COULD NOT BE ACHIEVED USING SMALLEST C ALLOWABLE STEPSIZE. USER MUST INCREASE THE ERROR C TOLERANCE BEFORE CONTINUED INTEGRATION CAN BE C ATTEMPTED. C = 6 -- GERK IS BEING USED INEFFICIENTLY IN SOLVING C THIS PROBLEM. TOO MUCH OUTPUT IS RESTRICTING THE C NATURAL STEPSIZE CHOICE. USE THE ONE-STEP C INTEGRATOR MODE. C = 7 -- INVALID INPUT PARAMETERS C THIS INDICATOR OCCURS IF ANY OF THE FOLLOWING IS C SATISFIED - NEQN .LE. 0 C T=TOUT AND IFLAG .NE. +1 OR -1 C RELERR OR ABSERR .LT. 0. C IFLAG .EQ. 0 OR .LT. -2 OR .GT. 7 C GERROR(*) -- ESTIMATE OF THE GLOBAL ERROR IN THE SOLUTION AT T C WORK(*),IWORK(*) -- INFORMATION WHICH IS USUALLY OF NO INTEREST C TO THE USER BUT NECESSARY FOR SUBSEQUENT CALLS. C WORK(1),...,WORK(NEQN) CONTAIN THE FIRST DERIVATIVES C OF THE SOLUTION VECTOR Y AT T. WORK(NEQN+1) CONTAINS C THE STEPSIZE H TO BE ATTEMPTED ON THE NEXT STEP. C IWORK(1) CONTAINS THE DERIVATIVE EVALUATION COUNTER. C C C*********************************************************************** C SUBSEQUENT CALLS TO GERK C*********************************************************************** C C SUBROUTINE GERK RETURNS WITH ALL INFORMATION NEEDED TO CONTINUE THE C INTEGRATION. IF THE INTEGRATION REACHED TOUT,THE USER NEED ONLY C DEFINE A NEW TOUT AND CALL GERK AGAIN. IN THE ONE-STEP INTEGRATOR C MODE (IFLAG=-2) THE USER MUST KEEP IN MIND THAT EACH STEP TAKEN IS C IN THE DIRECTION OF THE CURRENT TOUT. UPON REACHING TOUT (INDICATED C BY CHANGING IFLAG TO 2),THE USER MUST THEN DEFINE A NEW TOUT AND C RESET IFLAG TO -2 TO CONTINUE IN THE ONE-STEP INTEGRATOR MODE. C C IF THE INTEGRATION WAS NOT COMPLETED BUT THE USER STILL WANTS TO C CONTINUE (IFLAG=3 CASE), HE JUST CALLS GERK AGAIN. THE FUNCTION C COUNTER IS THEN RESET TO 0 AND ANOTHER 9000 FUNCTION EVALUATIONS C ARE ALLOWED. C C HOWEVER,IN THE CASE IFLAG=4, THE USER MUST FIRST ALTER THE ERROR C CRITERION TO USE A POSITIVE VALUE OF ABSERR BEFORE INTEGRATION CAN C PROCEED. IF HE DOES NOT,EXECUTION IS TERMINATED. C C ALSO,IN THE CASE IFLAG=5, IT IS NECESSARY FOR THE USER TO RESET C IFLAG TO 2 (OR -2 WHEN THE ONE-STEP INTEGRATION MODE IS BEING USED) C AS WELL AS INCREASING EITHER ABSERR,RELERR OR BOTH BEFORE THE C INTEGRATION CAN BE CONTINUED. IF THIS IS NOT DONE, EXECUTION WILL C BE TERMINATED. THE OCCURRENCE OF IFLAG=5 INDICATES A TROUBLE SPOT C (SOLUTION IS CHANGING RAPIDLY,SINGULARITY MAY BE PRESENT) AND IT C OFTEN IS INADVISABLE TO CONTINUE. C C IF IFLAG=6 IS ENCOUNTERED, THE USER SHOULD USE THE ONE-STEP C INTEGRATION MODE WITH THE STEPSIZE DETERMINED BY THE CODE. IF THE C USER INSISTS UPON CONTINUING THE INTEGRATION WITH GERK IN THE C INTERVAL MODE, HE MUST RESET IFLAG TO 2 BEFORE CALLING GERK AGAIN. C OTHERWISE,EXECUTION WILL BE TERMINATED. C C IF IFLAG=7 IS OBTAINED, INTEGRATION CAN NOT BE CONTINUED UNLESS C THE INVALID INPUT PARAMETERS ARE CORRECTED. C C IT SHOULD BE NOTED THAT THE ARRAYS WORK,IWORK CONTAIN INFORMATION C REQUIRED FOR SUBSEQUENT INTEGRATION. ACCORDINGLY, WORK AND IWORK C SHOULD NOT BE ALTERED. C C*********************************************************************** C DIMENSION Y(NEQN),GERROR(NEQN),WORK(*),IWORK(5) C EXTERNAL F C C C COMPUTE INDICES FOR THE SPLITTING OF THE WORK ARRAY C K1M=NEQN+1 K1=K1M+1 K2=K1+NEQN K3=K2+NEQN K4=K3+NEQN K5=K4+NEQN K6=K5+NEQN K7=K6+NEQN K8=K7+NEQN C C*********************************************************************** C THIS INTERFACING ROUTINE MERELY RELIEVES THE USER OF A LONG C CALLING LIST VIA THE SPLITTING APART OF TWO WORKING STORAGE C ARRAYS. IF THIS IS NOT COMPATIBLE WITH THE USERS COMPILER, C HE MUST USE GERKS DIRECTLY. C*********************************************************************** C CALL GERKS(F,NEQN,Y,T,TOUT,RELERR,ABSERR,IFLAG,GERROR, 1 WORK(1),WORK(K1M),WORK(K1),WORK(K2),WORK(K3),WORK(K4), 2 WORK(K5),WORK(K6),WORK(K7),WORK(K8),WORK(K8+1), 3 IWORK(1),IWORK(2),IWORK(3),IWORK(4),IWORK(5)) C RETURN END SUBROUTINE GERKS(F,NEQN,Y,T,TOUT,RELERR,ABSERR,IFLAG,GERROR, 1 YP,H,F1,F2,F3,F4,F5,YG,YGP,SAVRE,SAVAE, 2 NFE,KOP,INIT,JFLAG,KFLAG) C C FEHLBERG FOURTH(FIFTH) ORDER RUNGE-KUTTA METHOD WITH C GLOBAL ERROR ASSESSMENT C C*********************************************************************** C C GERKS INTEGRATES A SYSTEM OF FIRST ORDER ORDINARY DIFFERENTIAL C EQUATIONS AS DESCRIBED IN THE COMMENTS FOR GERK. THE ARRAYS C YP,F1,F2,F3,F4,F5,YG AND YGP (OF DIMENSION AT LEAST NEQN) AND C THE VARIABLES H,SAVRE,SAVAE,NFE,KOP,INIT,JFLAG,AND KFLAG ARE USED C INTERNALLY BY THE CODE AND APPEAR IN THE CALL LIST TO ELIMINATE C LOCAL RETENTION OF VARIABLES BETWEEN CALLS. ACCORDINGLY, THEY C SHOULD NOT BE ALTERED. ITEMS OF POSSIBLE INTEREST ARE C YP - DERIVATIVE OF SOLUTION VECTOR AT T C H - AN APPROPRIATE STEPSIZE TO BE USED FOR THE NEXT STEP C NFE- COUNTER ON THE NUMBER OF DERIVATIVE FUNCTION EVALUATIONS C C*********************************************************************** C LOGICAL HFAILD,OUTPUT C DIMENSION Y(NEQN),YP(NEQN),F1(NEQN),F2(NEQN),F3(NEQN),F4(NEQN), 1 F5(NEQN),YG(NEQN),YGP(NEQN),GERROR(NEQN) C EXTERNAL F C C*********************************************************************** C THE COMPUTER UNIT ROUNDOFF ERROR U IS THE SMALLEST POSITIVE VALUE C REPRESENTABLE IN THE MACHINE SUCH THAT 1.+ U .GT. 1. C U = SPMPAR(1) C C*********************************************************************** C C REMIN IS A TOLERANCE THRESHOLD WHICH IS ALSO DETERMINED BY THE C INTEGRATION METHOD. IN PARTICULAR, A FIFTH ORDER METHOD WILL C GENERALLY NOT BE CAPABLE OF DELIVERING ACCURACIES NEAR LIMITING C PRECISION ON COMPUTERS WITH LONG WORDLENGTHS. C REMIN = 3.E-11 C C*********************************************************************** C C THE EXPENSE IS CONTROLLED BY RESTRICTING THE NUMBER C OF FUNCTION EVALUATIONS TO BE APPROXIMATELY MAXNFE. C AS SET,THIS CORRESPONDS TO ABOUT 500 STEPS. C MAXNFE = 9000 C C*********************************************************************** C C C CHECK INPUT PARAMETERS C C IF (NEQN .LT. 1) GO TO 10 IF ((RELERR .LT. 0.) .OR. (ABSERR .LT. 0.)) GO TO 10 MFLAG=IABS(IFLAG) IF ((MFLAG .GE. 1) .AND. (MFLAG .LE. 7)) GO TO 20 C C INVALID INPUT 10 IFLAG=7 RETURN C C IS THIS THE FIRST CALL 20 IF (MFLAG .EQ. 1) GO TO 50 C C CHECK CONTINUATION POSSIBILITIES C IF (T .EQ. TOUT) GO TO 10 IF (MFLAG .NE. 2) GO TO 25 C C IFLAG = +2 OR -2 IF (INIT .EQ. 0) GO TO 45 IF (KFLAG .EQ. 3) GO TO 40 IF ((KFLAG .EQ. 4) .AND. (ABSERR .EQ. 0.)) GO TO 30 IF ((KFLAG .EQ. 5) .AND. (RELERR .LE. SAVRE) .AND. 1 (ABSERR .LE. SAVAE)) GO TO 30 GO TO 50 C C IFLAG = 3,4,5,6, OR 7 25 IF (IFLAG .EQ. 3) GO TO 40 IF ((IFLAG .EQ. 4) .AND. (ABSERR .GT. 0.)) GO TO 45 C C INTEGRATION CANNOT BE CONTINUED SINCE USER DID NOT RESPOND TO C THE INSTRUCTIONS PERTAINING TO IFLAG=4,5,6 OR 7 30 STOP C C*********************************************************************** C C RESET FUNCTION EVALUATION COUNTER 40 NFE=0 IF (MFLAG .EQ. 2) GO TO 50 C C RESET FLAG VALUE FROM PREVIOUS CALL 45 IFLAG=JFLAG C C SAVE INPUT IFLAG AND SET CONTINUATION FLAG VALUE FOR SUBSEQUENT C INPUT CHECKING 50 JFLAG=IFLAG KFLAG=0 C C SAVE RELERR AND ABSERR FOR CHECKING INPUT ON SUBSEQUENT CALLS SAVRE=RELERR SAVAE=ABSERR C C RESTRICT RELATIVE ERROR TOLERANCE TO BE AT LEAST AS LARGE AS C 32U+REMIN TO AVOID LIMITING PRECISION DIFFICULTIES ARISING FROM C IMPOSSIBLE ACCURACY REQUESTS C RER=AMAX1(RELERR,32.*U+REMIN) C U26=26.*U C DT=TOUT-T C IF (MFLAG .EQ. 1) GO TO 60 IF (INIT .EQ. 0) GO TO 65 GO TO 80 C C C*********************************************************************** C C INITIALIZATION -- C SET INITIALIZATION COMPLETION INDICATOR,INIT C SET INDICATOR FOR TOO MANY OUTPUT POINTS,KOP C EVALUATE INITIAL DERIVATIVES C COPY INITIAL VALUES AND DERIVATIVES FOR THE C PARALLEL SOLUTION C SET COUNTER FOR FUNCTION EVALUATIONS,NFE C ESTIMATE STARTING STEPSIZE C 60 INIT=0 KOP=0 C A=T CALL F(A,Y,YP) NFE=1 IF (T .NE. TOUT) GO TO 65 IFLAG=2 RETURN C C 65 INIT=1 H=ABS(DT) TOLN=0. DO 70 K=1,NEQN YG(K)=Y(K) YGP(K)=YP(K) TOL=RER*ABS(Y(K))+ABSERR IF (TOL .LE. 0.) GO TO 70 TOLN=TOL YPK=ABS(YP(K)) IF (YPK*H**5 .GT. TOL) H=(TOL/YPK)**0.2 70 CONTINUE IF (TOLN .LE. 0.) H=0. H=AMAX1(H,U26*AMAX1(ABS(T),ABS(DT))) C C C*********************************************************************** C C SET STEPSIZE FOR INTEGRATION IN THE DIRECTION FROM T TO TOUT C 80 H=SIGN(H,DT) C C TEST TO SEE IF GERK IS BEING SEVERELY IMPACTED BY TOO MANY C OUTPUT POINTS C IF (ABS(H) .GT. 2.*ABS(DT)) KOP=KOP+1 IF (KOP .NE. 100) GO TO 85 KOP=0 IFLAG=6 RETURN C 85 IF (ABS(DT) .GT. U26*ABS(T)) GO TO 95 C C IF TOO CLOSE TO OUTPUT POINT,EXTRAPOLATE AND RETURN C DO 90 K=1,NEQN YG(K)=YG(K)+DT*YGP(K) 90 Y(K)=Y(K)+DT*YP(K) A=TOUT CALL F(A,YG,YGP) CALL F(A,Y,YP) NFE=NFE+2 GO TO 300 C C INITIALIZE OUTPUT POINT INDICATOR C 95 OUTPUT= .FALSE. C C TO AVOID PREMATURE UNDERFLOW IN THE ERROR TOLERANCE FUNCTION, C SCALE THE ERROR TOLERANCES C SCALE=2./RER AE=SCALE*ABSERR C C C*********************************************************************** C*********************************************************************** C STEP BY STEP INTEGRATION C 100 HFAILD= .FALSE. C C SET SMALLEST ALLOWABLE STEPSIZE C HMIN=U26*ABS(T) C C ADJUST STEPSIZE IF NECESSARY TO HIT THE OUTPUT POINT. C LOOK AHEAD TWO STEPS TO AVOID DRASTIC CHANGES IN THE STEPSIZE C AND THUS LESSEN THE IMPACT OF OUTPUT POINTS ON THE CODE. C DT=TOUT-T IF (ABS(DT) .GE. 2.*ABS(H)) GO TO 200 IF (ABS(DT) .GT. ABS(H)) GO TO 150 C C THE NEXT SUCCESSFUL STEP WILL COMPLETE THE INTEGRATION TO THE C OUTPUT POINT C OUTPUT= .TRUE. H=DT GO TO 200 C 150 H=0.5*DT C C C C*********************************************************************** C CORE INTEGRATOR FOR TAKING A SINGLE STEP C*********************************************************************** C THE TOLERANCES HAVE BEEN SCALED TO AVOID PREMATURE UNDERFLOW IN C COMPUTING THE ERROR TOLERANCE FUNCTION ET. C TO AVOID PROBLEMS WITH ZERO CROSSINGS,RELATIVE ERROR IS MEASURED C USING THE AVERAGE OF THE MAGNITUDES OF THE SOLUTION AT THE C BEGINNING AND END OF A STEP. C THE ERROR ESTIMATE FORMULA HAS BEEN GROUPED TO CONTROL LOSS OF C SIGNIFICANCE. C TO DISTINGUISH THE VARIOUS ARGUMENTS, H IS NOT PERMITTED C TO BECOME SMALLER THAN 26 UNITS OF ROUNDOFF IN T. C PRACTICAL LIMITS ON THE CHANGE IN THE STEPSIZE ARE ENFORCED TO C SMOOTH THE STEPSIZE SELECTION PROCESS AND TO AVOID EXCESSIVE C CHATTERING ON PROBLEMS HAVING DISCONTINUITIES. C TO PREVENT UNNECESSARY FAILURES, THE CODE USES 9/10 THE STEPSIZE C IT ESTIMATES WILL SUCCEED. C AFTER A STEP FAILURE, THE STEPSIZE IS NOT ALLOWED TO INCREASE FOR C THE NEXT ATTEMPTED STEP. THIS MAKES THE CODE MORE EFFICIENT ON C PROBLEMS HAVING DISCONTINUITIES AND MORE EFFECTIVE IN GENERAL C SINCE LOCAL EXTRAPOLATION IS BEING USED AND THE ERROR ESTIMATE C MAY BE UNRELIABLE OR UNACCEPTABLE WHEN A STEP FAILS. C*********************************************************************** C C C TEST NUMBER OF DERIVATIVE FUNCTION EVALUATIONS. C IF OKAY,TRY TO ADVANCE THE INTEGRATION FROM T TO T+H C 200 IF (NFE .LE. MAXNFE) GO TO 220 C C TOO MUCH WORK IFLAG=3 KFLAG=3 RETURN C C ADVANCE AN APPROXIMATE SOLUTION OVER ONE STEP OF LENGTH H C 220 CALL FEHL(F,NEQN,YG,T,H,YGP,F1,F2,F3,F4,F5,F1) NFE=NFE+5 C C COMPUTE AND TEST ALLOWABLE TOLERANCES VERSUS LOCAL ERROR ESTIMATES C AND REMOVE SCALING OF TOLERANCES. NOTE THAT RELATIVE ERROR IS C MEASURED WITH RESPECT TO THE AVERAGE OF THE MAGNITUDES OF THE C SOLUTION AT THE BEGINNING AND END OF THE STEP. C EEOET=0. DO 250 K=1,NEQN ET=ABS(YG(K))+ABS(F1(K))+AE IF (ET .GT. 0.) GO TO 240 C C INAPPROPRIATE ERROR TOLERANCE IFLAG=4 KFLAG=4 RETURN C 240 EE=ABS((-2090.*YGP(K)+(21970.*F3(K)-15048.*F4(K)))+ 1 (22528.*F2(K)-27360.*F5(K))) 250 EEOET=AMAX1(EEOET,EE/ET) C ESTTOL=ABS(H)*EEOET*SCALE/752400. C IF (ESTTOL .LE. 1.) GO TO 260 C C C UNSUCCESSFUL STEP C REDUCE THE STEPSIZE , TRY AGAIN C THE DECREASE IS LIMITED TO A FACTOR OF 1/10 C HFAILD= .TRUE. OUTPUT= .FALSE. S=0.1 IF (ESTTOL .LT. 59049.) S=0.9/ESTTOL**0.2 H=S*H IF (ABS(H) .GT. HMIN) GO TO 200 C C REQUESTED ERROR UNATTAINABLE AT SMALLEST ALLOWABLE STEPSIZE IFLAG=5 KFLAG=5 RETURN C C C SUCCESSFUL STEP C STORE ONE-STEP SOLUTION YG AT T+H C AND EVALUATE DERIVATIVES THERE C 260 TS=T T=T+H DO 270 K=1,NEQN 270 YG(K)=F1(K) A=T CALL F(A,YG,YGP) NFE=NFE+1 C C NOW ADVANCE THE Y SOLUTION OVER TWO STEPS OF C LENGTH H/2 AND EVALUATE DERIVATIVES THERE C HH=0.5*H CALL FEHL(F,NEQN,Y,TS,HH,YP,F1,F2,F3,F4,F5,Y) TS=TS+HH A=TS CALL F(A,Y,YP) CALL FEHL(F,NEQN,Y,TS,HH,YP,F1,F2,F3,F4,F5,Y) A=T CALL F(A,Y,YP) NFE=NFE+12 C C C CHOOSE NEXT STEPSIZE C THE INCREASE IS LIMITED TO A FACTOR OF 5 C IF STEP FAILURE HAS JUST OCCURRED, NEXT C STEPSIZE IS NOT ALLOWED TO INCREASE C S=5. IF (ESTTOL .GT. 1.889568E-4) S=0.9/ESTTOL**0.2 IF (HFAILD) S=AMIN1(S,1.) H=SIGN(AMAX1(S*ABS(H),HMIN),H) C C*********************************************************************** C END OF CORE INTEGRATOR C*********************************************************************** C C C C SHOULD WE TAKE ANOTHER STEP C IF (OUTPUT) GO TO 300 IF (IFLAG .GT. 0) GO TO 100 C C*********************************************************************** C*********************************************************************** C C C INTEGRATION SUCCESSFULLY COMPLETED C C ONE-STEP MODE IFLAG=-2 GO TO 400 C C INTERVAL MODE 300 T=TOUT IFLAG=2 C 400 DO 450 K=1,NEQN 450 GERROR(K)=(YG(K)-Y(K))/31. C RETURN END SUBROUTINE SFODE (F,NEQ,Y,T,TOUT,INFO,RERR,AERR,IDID, * RWORK,LRW,IWORK,LIW,RPAR,IPAR) C -------------- EXTERNAL F, ZZZJAC REAL Y(NEQ), RTOL(1), ATOL(1), RWORK(LRW), RPAR(*) INTEGER INFO(*), INFO1(15), IWORK(LIW), IPAR(*) C -------------- INFO1(1) = INFO(1) INFO1(2) = 0 INFO1(3) = INFO(2) INFO1(4) = INFO(3) INFO1(5) = 0 INFO1(6) = INFO(4) C RTOL(1) = RERR ATOL(1) = AERR CALL STFODE (F,NEQ,Y,T,TOUT,INFO1,RTOL,ATOL,IDID, * RWORK,LRW,IWORK,LIW,RPAR,IPAR,ZZZJAC) INFO(1) = INFO1(1) RERR = RTOL(1) AERR = ATOL(1) RETURN END SUBROUTINE SFODE1 (F,NEQ,Y,T,TOUT,INFO,RTOL,ATOL,IDID, * RWORK,LRW,IWORK,LIW,RPAR,IPAR) C -------------- EXTERNAL F, ZZZJAC REAL Y(NEQ), RTOL(NEQ), ATOL(NEQ), RWORK(LRW), RPAR(*) INTEGER INFO(*), INFO1(15), IWORK(LIW), IPAR(*) C -------------- INFO1(1) = INFO(1) INFO1(2) = 1 INFO1(3) = INFO(2) INFO1(4) = INFO(3) INFO1(5) = 0 INFO1(6) = INFO(4) C CALL STFODE (F,NEQ,Y,T,TOUT,INFO1,RTOL,ATOL,IDID, * RWORK,LRW,IWORK,LIW,RPAR,IPAR,ZZZJAC) INFO(1) = INFO1(1) RETURN END SUBROUTINE ZZZJAC(T,Y,PD,N,RPAR,IPAR) C ------------- C DUMMY JACOBIAN SUBROUTINE C ------------- DIMENSION Y(N), PD(N,*) DIMENSION RPAR(*), IPAR(*) C ------------- T = 0.0 RETURN END SUBROUTINE STFODE (F,NEQ,Y,T,TOUT,INFO,RTOL,ATOL,IDID, 1 RWORK,LRW,IWORK,LIW,RPAR,IPAR,JAC) C*********************************************************************** C***PURPOSE C STFODE SOLVES INITIAL VALUE PROBLEMS IN ORDINARY DIFFERENTIAL C EQUATIONS USING BACKWARD DIFFERENTIATION FORMULAS. IT IS C BOTH VARIABLE ORDER (1-5) AND VARIABLE STEP. C***DESCRIPTION C C THIS IS A MODIFICATION BY A. H. MORRIS (NSWC) OF THE CODE C DEBDF, DESIGNED BY L. F. SHAMPINE AND H. A. WATTS (1980). C DEBDF IS DOCUMENTED IN C SAND79-2374 , DEPAC - DESIGN OF A USER ORIENTED PACKAGE C OF ODE SOLVERS. C C STFODE IS A DRIVER FOR A MODIFICATION OF THE CODE LSODE WRITTEN BY C A. C. HINDMARSH C LAWRENCE LIVERMORE LABORATORY C LIVERMORE, CALIFORNIA 94550 C C*********************************************************************** C** ABSTRACT ** C************** C C SUBROUTINE STFODE USES THE BACKWARD DIFFERENTIATION FORMULAS OF C ORDERS ONE THROUGH FIVE TO INTEGRATE A SYSTEM OF NEQ FIRST ORDER C ORDINARY DIFFERENTIAL EQUATIONS OF THE FORM C DU/DX = F(X,U) C WHEN THE VECTOR Y(*) OF INITIAL VALUES FOR U(*) AT X=T IS GIVEN. C THE SUBROUTINE INTEGRATES FROM T TO TOUT. IT IS EASY TO CONTINUE THE C INTEGRATION TO GET RESULTS AT ADDITIONAL TOUT. THIS IS THE INTERVAL C MODE OF OPERATION. IT IS ALSO EASY FOR THE ROUTINE TO RETURN WITH C THE SOLUTION AT EACH INTERMEDIATE STEP ON THE WAY TO TOUT. THIS IS C THE INTERMEDIATE-OUTPUT MODE OF OPERATION. C C STFODE USES SUBPROGRAMS LSOD1, INTYD, STOD, CFOD, PJAC, SLVS,VNWRMS, C HSTART, VNORM, SVCO, RSCO, SPMPAR, AND THE LINPACK ROUTINES SGEFA, C SGESL, SGBFA, SGBSL (WHICH ALSO USE THE BLAS ROUTINES SAXPY, SSCAL, C ISAMAX AND SDOT). THE ONLY MACHINE DEPENDENT PARAMETERS USED APPEAR C IN SPMPAR. C C*********************************************************************** C** DESCRIPTION OF THE ARGUMENTS TO STFODE (AN OVERVIEW) ** C********************************************************** C C THE PARAMETERS ARE C C F -- THIS IS THE NAME OF A SUBROUTINE WHICH YOU PROVIDE TO C DEFINE THE DIFFERENTIAL EQUATIONS. C C NEQ -- THIS IS THE NUMBER OF (FIRST ORDER) DIFFERENTIAL C EQUATIONS TO BE INTEGRATED. C C T -- THIS IS A VALUE OF THE INDEPENDENT VARIABLE. C C Y(*) -- THIS ARRAY CONTAINS THE SOLUTION COMPONENTS AT T. C C TOUT -- THIS IS A POINT AT WHICH A SOLUTION IS DESIRED. C C INFO(*) -- THE BASIC TASK OF THE CODE IS TO INTEGRATE THE C DIFFERENTIAL EQUATIONS FROM T TO TOUT AND RETURN AN C ANSWER AT TOUT. INFO(*) IS AN INTEGER ARRAY WHICH IS USED C TO COMMUNICATE EXACTLY HOW YOU WANT THIS TASK TO BE C CARRIED OUT. C C RTOL, ATOL -- THESE QUANTITIES REPRESENT RELATIVE AND ABSOLUTE C ERROR TOLERANCES WHICH YOU PROVIDE TO INDICATE HOW C ACCURATELY YOU WISH THE SOLUTION TO BE COMPUTED. YOU MAY C CHOOSE THEM TO BE BOTH SCALARS OR ELSE BOTH VECTORS. C C IDID -- THIS SCALAR QUANTITY IS AN INDICATOR REPORTING WHAT C THE CODE DID. YOU MUST MONITOR THIS INTEGER VARIABLE TO C DECIDE WHAT ACTION TO TAKE NEXT. C C RWORK(*), LRW -- RWORK(*) IS A REAL WORK ARRAY OF LENGTH LRW C WHICH PROVIDES THE CODE WITH NEEDED STORAGE SPACE. C C IWORK(*), LIW -- IWORK(*) IS AN INTEGER WORK ARRAY OF LENGTH LIW C WHICH PROVIDES THE CODE WITH NEEDED STORAGE SPACE. C C RPAR, IPAR -- THESE ARE REAL AND INTEGER PARAMETER ARRAYS WHICH C YOU CAN USE FOR COMMUNICATION BETWEEN YOUR CALLING C PROGRAM AND THE F SUBROUTINE (AND THE JAC SUBROUTINE). C C JAC -- THIS IS THE NAME OF A SUBROUTINE WHICH YOU MAY CHOOSE TO C PROVIDE FOR DEFINING THE JACOBIAN MATRIX OF PARTIAL C DERIVATIVES DF/DU. C C QUANTITIES WHICH ARE USED AS INPUT ITEMS ARE C NEQ, T, Y(*), TOUT, INFO(*), C RTOL, ATOL, RWORK(1), LRW, C IWORK(1), IWORK(2), AND LIW. C C QUANTITIES WHICH MAY BE ALTERED BY THE CODE ARE C T, Y(*), INFO(1), RTOL, ATOL, C IDID, RWORK(*) AND IWORK(*). C C*********************************************************************** C** INPUT -- WHAT TO DO ON THE FIRST CALL TO STFODE ** C***************************************************** C C THE FIRST CALL OF THE CODE IS DEFINED TO BE THE START OF EACH NEW C PROBLEM. READ THROUGH THE DESCRIPTIONS OF ALL THE FOLLOWING ITEMS, C PROVIDE SUFFICIENT STORAGE SPACE FOR DESIGNATED ARRAYS, SET C APPROPRIATE VARIABLES FOR THE INITIALIZATION OF THE PROBLEM, AND C GIVE INFORMATION ABOUT HOW YOU WANT THE PROBLEM TO BE SOLVED. C C C F -- PROVIDE A SUBROUTINE OF THE FORM C F(X,U,UPRIME,RPAR,IPAR) C TO DEFINE THE SYSTEM OF FIRST ORDER DIFFERENTIAL EQUATIONS C WHICH IS TO BE SOLVED. FOR THE GIVEN VALUES OF X AND THE C VECTOR U(*)=(U(1),U(2),...,U(NEQ)) , THE SUBROUTINE MUST C EVALUATE THE NEQ COMPONENTS OF THE SYSTEM OF DIFFERENTIAL C EQUATIONS DU/DX=F(X,U) AND STORE THE DERIVATIVES IN THE C ARRAY UPRIME(*), THAT IS, UPRIME(I) = * DU(I)/DX * FOR C EQUATIONS I=1,...,NEQ. C C SUBROUTINE F MUST NOT ALTER X OR U(*). YOU MUST DECLARE C THE NAME F IN AN EXTERNAL STATEMENT IN YOUR PROGRAM THAT C CALLS STFODE. YOU MUST DIMENSION U AND UPRIME IN F. C C RPAR AND IPAR ARE REAL AND INTEGER PARAMETER ARRAYS WHICH C YOU CAN USE FOR COMMUNICATION BETWEEN YOUR CALLING PROGRAM C AND SUBROUTINE F. THEY ARE NOT USED OR ALTERED BY STFODE. C IF YOU DO NOT NEED RPAR OR IPAR, IGNORE THESE PARAMETERS C BY TREATING THEM AS DUMMY ARGUMENTS. IF YOU DO CHOOSE TO C USE THEM, DIMENSION THEM IN YOUR CALLING PROGRAM AND IN F C AS ARRAYS OF APPROPRIATE LENGTH. C C NEQ -- SET IT TO THE NUMBER OF DIFFERENTIAL EQUATIONS. C (NEQ .GE. 1) C C T -- SET IT TO THE INITIAL POINT OF THE INTEGRATION. C YOU MUST USE A PROGRAM VARIABLE FOR T BECAUSE THE CODE C CHANGES ITS VALUE. C C Y(*) -- SET THIS VECTOR TO THE INITIAL VALUES OF THE NEQ SOLUTION C COMPONENTS AT THE INITIAL POINT. YOU MUST DIMENSION Y AT C LEAST NEQ IN YOUR CALLING PROGRAM. C C TOUT -- SET IT TO THE FIRST POINT AT WHICH A SOLUTION C IS DESIRED. YOU CAN TAKE TOUT = T, IN WHICH CASE THE CODE C WILL EVALUATE THE DERIVATIVE OF THE SOLUTION AT T AND C RETURN. INTEGRATION EITHER FORWARD IN T (TOUT .GT. T) OR C BACKWARD IN T (TOUT .LT. T) IS PERMITTED. C C THE CODE ADVANCES THE SOLUTION FROM T TO TOUT USING C STEP SIZES WHICH ARE AUTOMATICALLY SELECTED SO AS TO C ACHIEVE THE DESIRED ACCURACY. IF YOU WISH, THE CODE WILL C RETURN WITH THE SOLUTION AND ITS DERIVATIVE FOLLOWING C EACH INTERMEDIATE STEP (INTERMEDIATE-OUTPUT MODE) SO THAT C YOU CAN MONITOR THEM, BUT YOU STILL MUST PROVIDE TOUT IN C ACCORD WITH THE BASIC AIM OF THE CODE. C C THE FIRST STEP TAKEN BY THE CODE IS A CRITICAL ONE C BECAUSE IT MUST REFLECT HOW FAST THE SOLUTION CHANGES NEAR C THE INITIAL POINT. THE CODE AUTOMATICALLY SELECTS AN C INITIAL STEP SIZE WHICH IS PRACTICALLY ALWAYS SUITABLE FOR C THE PROBLEM. BY USING THE FACT THAT THE CODE WILL NOT STEP C PAST TOUT IN THE FIRST STEP, YOU COULD, IF NECESSARY, C RESTRICT THE LENGTH OF THE INITIAL STEP SIZE. C C FOR SOME PROBLEMS IT MAY NOT BE PERMISSIBLE TO INTEGRATE C PAST A POINT TSTOP BECAUSE A DISCONTINUITY OCCURS THERE C OR THE SOLUTION OR ITS DERIVATIVE IS NOT DEFINED BEYOND C TSTOP. WHEN YOU HAVE DECLARED A TSTOP POINT (SEE INFO(4) C AND RWORK(1)), YOU HAVE TOLD THE CODE NOT TO INTEGRATE C PAST TSTOP. IN THIS CASE ANY TOUT BEYOND TSTOP IS INVALID C INPUT. C C INFO(*) -- USE THE INFO ARRAY TO GIVE THE CODE MORE DETAILS ABOUT C HOW YOU WANT YOUR PROBLEM SOLVED. THIS ARRAY SHOULD BE C DIMENSIONED OF LENGTH 15 TO ACCOMODATE OTHER MEMBERS OF C DEPAC OR POSSIBLE FUTURE EXTENSIONS, THOUGH STFODE USES C ONLY THE FIRST SIX ENTRIES. YOU MUST RESPOND TO ALL OF C THE FOLLOWING ITEMS WHICH ARE ARRANGED AS QUESTIONS. THE C SIMPLEST USE OF THE CODE CORRESPONDS TO ANSWERING ALL C QUESTIONS AS YES ,I.E. SETTING ALL ENTRIES OF INFO TO 0. C C INFO(1) -- THIS PARAMETER ENABLES THE CODE TO INITIALIZE C ITSELF. YOU MUST SET IT TO INDICATE THE START OF EVERY C NEW PROBLEM. C C **** IS THIS THE FIRST CALL FOR THIS PROBLEM ... C YES -- SET INFO(1) = 0 C NO -- NOT APPLICABLE HERE. C SEE BELOW FOR CONTINUATION CALLS. **** C C INFO(2) -- HOW MUCH ACCURACY YOU WANT OF YOUR SOLUTION C IS SPECIFIED BY THE ERROR TOLERANCES RTOL AND ATOL. C THE SIMPLEST USE IS TO TAKE THEM BOTH TO BE SCALARS. C TO OBTAIN MORE FLEXIBILITY, THEY CAN BOTH BE VECTORS. C THE CODE MUST BE TOLD YOUR CHOICE. C C **** ARE BOTH ERROR TOLERANCES RTOL, ATOL SCALARS ... C YES -- SET INFO(2) = 0 C AND INPUT SCALARS FOR BOTH RTOL AND ATOL C NO -- SET INFO(2) = 1 C AND INPUT ARRAYS FOR BOTH RTOL AND ATOL **** C C INFO(3) -- THE CODE INTEGRATES FROM T IN THE DIRECTION C OF TOUT BY STEPS. IF YOU WISH, IT WILL RETURN THE C COMPUTED SOLUTION AND DERIVATIVE AT THE NEXT C INTERMEDIATE STEP (THE INTERMEDIATE-OUTPUT MODE) OR C TOUT, WHICHEVER COMES FIRST. THIS IS A GOOD WAY TO C PROCEED IF YOU WANT TO SEE THE BEHAVIOR OF THE SOLUTION. C IF YOU MUST HAVE SOLUTIONS AT A GREAT MANY SPECIFIC C TOUT POINTS, THIS CODE WILL COMPUTE THEM EFFICIENTLY. C C **** DO YOU WANT THE SOLUTION ONLY AT C TOUT (AND NOT AT THE NEXT INTERMEDIATE STEP) ... C YES -- SET INFO(3) = 0 C NO -- SET INFO(3) = 1 **** C C INFO(4) -- TO HANDLE SOLUTIONS AT A GREAT MANY SPECIFIC C VALUES TOUT EFFICIENTLY, THIS CODE MAY INTEGRATE PAST C TOUT AND INTERPOLATE TO OBTAIN THE RESULT AT TOUT. C SOMETIMES IT IS NOT POSSIBLE TO INTEGRATE BEYOND SOME C POINT TSTOP BECAUSE THE EQUATION CHANGES THERE OR IT IS C NOT DEFINED PAST TSTOP. THEN YOU MUST TELL THE CODE C NOT TO GO PAST. C C **** CAN THE INTEGRATION BE CARRIED OUT WITHOUT ANY C RESTRICTIONS ON THE INDEPENDENT VARIABLE T ... C YES -- SET INFO(4)=0 C NO -- SET INFO(4)=1 C AND DEFINE THE STOPPING POINT TSTOP BY C SETTING RWORK(1)=TSTOP **** C C INFO(5) -- TO SOLVE STIFF PROBLEMS IT IS NECESSARY TO USE THE C JACOBIAN MATRIX OF PARTIAL DERIVATIVES OF THE SYSTEM C OF DIFFERENTIAL EQUATIONS. IF YOU DO NOT PROVIDE A C SUBROUTINE TO EVALUATE IT ANALYTICALLY (SEE THE C DESCRIPTION OF THE ITEM JAC IN THE CALL LIST), IT WILL C BE APPROXIMATED BY NUMERICAL DIFFERENCING IN THIS CODE. C ALTHOUGH IT IS LESS TROUBLE FOR YOU TO HAVE THE CODE C COMPUTE PARTIAL DERIVATIVES BY NUMERICAL DIFFERENCING, C THE SOLUTION WILL BE MORE RELIABLE IF YOU PROVIDE THE C DERIVATIVES VIA JAC. SOMETIMES NUMERICAL DIFFERENCING C IS CHEAPER THAN EVALUATING DERIVATIVES IN JAC AND C SOMETIMES IT IS NOT - THIS DEPENDS ON YOUR PROBLEM. C C IF YOUR PROBLEM IS LINEAR, I.E. HAS THE FORM C DU/DX = F(X,U) = J(X)*U + G(X) FOR SOME MATRIX J(X) C AND VECTOR G(X), THE JACOBIAN MATRIX DF/DU = J(X). C SINCE YOU MUST PROVIDE A SUBROUTINE TO EVALUATE F(X,U) C ANALYTICALLY, IT IS LITTLE EXTRA TROUBLE TO PROVIDE C SUBROUTINE JAC FOR EVALUATING J(X) ANALYTICALLY. C FURTHERMORE, IN SUCH CASES, NUMERICAL DIFFERENCING IS C MUCH MORE EXPENSIVE THAN ANALYTIC EVALUATION. C C **** DO YOU WANT THE CODE TO EVALUATE THE PARTIAL C DERIVATIVES AUTOMATICALLY BY NUMERICAL DIFFERENCES ... C YES -- SET INFO(5)=0 C NO -- SET INFO(5)=1 C AND PROVIDE SUBROUTINE JAC FOR EVALUATING THE C JACOBIAN MATRIX **** C C INFO(6) -- STFODE WILL PERFORM MUCH BETTER IF THE JACOBIAN C MATRIX IS BANDED AND THE CODE IS TOLD THIS. IN THIS C CASE, THE STORAGE NEEDED WILL BE GREATLY REDUCED, C NUMERICAL DIFFERENCING WILL BE PERFORMED MORE CHEAPLY, C AND A NUMBER OF IMPORTANT ALGORITHMS WILL EXECUTE MUCH C FASTER. THE DIFFERENTIAL EQUATION IS SAID TO HAVE C HALF-BANDWIDTHS ML (LOWER) AND MU (UPPER) IF EQUATION I C INVOLVES ONLY UNKNOWNS Y(J) WITH C I-ML .LE. J .LE. I+MU C FOR ALL I=1,2,...,NEQ. THUS, ML AND MU ARE THE WIDTHS C OF THE LOWER AND UPPER PARTS OF THE BAND, RESPECTIVELY, C WITH THE MAIN DIAGONAL BEING EXCLUDED. IF YOU DO NOT C INDICATE THAT THE EQUATION HAS A BANDED JACOBIAN, C THE CODE WORKS WITH A FULL MATRIX OF NEQ**2 ELEMENTS C (STORED IN THE CONVENTIONAL WAY). COMPUTATIONS WITH C BANDED MATRICES COST LESS TIME AND STORAGE THAN WITH C FULL MATRICES IF 2*ML+MU .LT. NEQ. IF YOU TELL THE C CODE THAT THE JACOBIAN MATRIX HAS A BANDED STRUCTURE AND C YOU WANT TO PROVIDE SUBROUTINE JAC TO COMPUTE THE C PARTIAL DERIVATIVES, THEN YOU MUST BE CAREFUL TO STORE C THE ELEMENTS OF THE JACOBIAN MATRIX IN THE SPECIAL FORM C INDICATED IN THE DESCRIPTION OF JAC. C C **** DO YOU WANT TO SOLVE THE PROBLEM USING A FULL C (DENSE) JACOBIAN MATRIX (AND NOT A SPECIAL BANDED C STRUCTURE) ... C YES -- SET INFO(6)=0 C NO -- SET INFO(6)=1 C AND PROVIDE THE LOWER (ML) AND UPPER (MU) C BANDWIDTHS BY SETTING C IWORK(1)=ML C IWORK(2)=MU **** C C RTOL, ATOL -- YOU MUST ASSIGN RELATIVE (RTOL) AND ABSOLUTE (ATOL) C ERROR TOLERANCES TO TELL THE CODE HOW ACCURATELY YOU WANT C THE SOLUTION TO BE COMPUTED. THEY MUST BE DEFINED AS C PROGRAM VARIABLES BECAUSE THE CODE MAY CHANGE THEM. YOU C HAVE TWO CHOICES -- C BOTH RTOL AND ATOL ARE SCALARS. (INFO(2)=0) C BOTH RTOL AND ATOL ARE VECTORS. (INFO(2)=1) C IN EITHER CASE ALL COMPONENTS MUST BE NON-NEGATIVE. C C THE TOLERANCES ARE USED BY THE CODE IN A LOCAL ERROR TEST C AT EACH STEP WHICH REQUIRES ROUGHLY THAT C ABS(LOCAL ERROR) .LE. RTOL*ABS(Y)+ATOL C FOR EACH VECTOR COMPONENT. C (MORE SPECIFICALLY, A ROOT-MEAN-SQUARE NORM IS USED TO C MEASURE THE SIZE OF VECTORS, AND THE ERROR TEST USES THE C MAGNITUDE OF THE SOLUTION AT THE BEGINNING OF THE STEP.) C C THE TRUE (GLOBAL) ERROR IS THE DIFFERENCE BETWEEN THE TRUE C SOLUTION OF THE INITIAL VALUE PROBLEM AND THE COMPUTED C APPROXIMATION. PRACTICALLY ALL PRESENT DAY CODES, C INCLUDING THIS ONE, CONTROL THE LOCAL ERROR AT EACH STEP C AND DO NOT EVEN ATTEMPT TO CONTROL THE GLOBAL ERROR C DIRECTLY. ROUGHLY SPEAKING, THEY PRODUCE A SOLUTION Y(T) C WHICH SATISFIES THE DIFFERENTIAL EQUATIONS WITH A C RESIDUAL R(T), DY(T)/DT = F(T,Y(T)) + R(T) , C AND, ALMOST ALWAYS, R(T) IS BOUNDED BY THE ERROR C TOLERANCES. USUALLY, BUT NOT ALWAYS, THE TRUE ACCURACY OF C THE COMPUTED Y IS COMPARABLE TO THE ERROR TOLERANCES. THIS C CODE WILL USUALLY, BUT NOT ALWAYS, DELIVER A MORE ACCURATE C SOLUTION IF YOU REDUCE THE TOLERANCES AND INTEGRATE AGAIN. C BY COMPARING TWO SUCH SOLUTIONS YOU CAN GET A FAIRLY C RELIABLE IDEA OF THE TRUE ERROR IN THE SOLUTION AT THE C BIGGER TOLERANCES. C C SETTING ATOL=0. RESULTS IN A PURE RELATIVE ERROR TEST ON C THAT COMPONENT. SETTING RTOL=0. RESULTS IN A PURE ABSOLUTE C ERROR TEST ON THAT COMPONENT. A MIXED TEST WITH NON-ZERO C RTOL AND ATOL CORRESPONDS ROUGHLY TO A RELATIVE ERROR C TEST WHEN THE SOLUTION COMPONENT IS MUCH BIGGER THAN ATOL C AND TO AN ABSOLUTE ERROR TEST WHEN THE SOLUTION COMPONENT C IS SMALLER THAN THE THRESHOLD ATOL. C C PROPER SELECTION OF THE ABSOLUTE ERROR CONTROL PARAMETERS C ATOL REQUIRES YOU TO HAVE SOME IDEA OF THE SCALE OF THE C SOLUTION COMPONENTS. TO ACQUIRE THIS INFORMATION MAY MEAN C THAT YOU WILL HAVE TO SOLVE THE PROBLEM MORE THAN ONCE. IN C THE ABSENCE OF SCALE INFORMATION, YOU SHOULD ASK FOR SOME C RELATIVE ACCURACY IN ALL THE COMPONENTS (BY SETTING RTOL C VALUES NON-ZERO) AND PERHAPS IMPOSE EXTREMELY SMALL C ABSOLUTE ERROR TOLERANCES TO PROTECT AGAINST THE DANGER OF C A SOLUTION COMPONENT BECOMING ZERO. C C THE CODE WILL NOT ATTEMPT TO COMPUTE A SOLUTION AT AN C ACCURACY UNREASONABLE FOR THE MACHINE BEING USED. IT WILL C ADVISE YOU IF YOU ASK FOR TOO MUCH ACCURACY AND INFORM C YOU AS TO THE MAXIMUM ACCURACY IT BELIEVES POSSIBLE. C C RWORK(*) -- DIMENSION THIS REAL WORK ARRAY OF LENGTH LRW IN YOUR C CALLING PROGRAM. C C RWORK(1) -- IF YOU HAVE SET INFO(4)=0, YOU CAN IGNORE THIS C OPTIONAL INPUT PARAMETER. OTHERWISE YOU MUST DEFINE A C STOPPING POINT TSTOP BY SETTING RWORK(1) = TSTOP. C (FOR SOME PROBLEMS IT MAY NOT BE PERMISSIBLE TO INTEGRATE C PAST A POINT TSTOP BECAUSE A DISCONTINUITY OCCURS THERE C OR THE SOLUTION OR ITS DERIVATIVE IS NOT DEFINED BEYOND C TSTOP.) C C LRW -- SET IT TO THE DECLARED LENGTH OF THE RWORK ARRAY. C YOU MUST HAVE C LRW .GE. 250+10*NEQ+NEQ**2 C FOR THE FULL (DENSE) JACOBIAN CASE (WHEN INFO(6)=0), OR C LRW .GE. 250+10*NEQ+(2*ML+MU+1)*NEQ C FOR THE BANDED JACOBIAN CASE (WHEN INFO(6)=1). C C IWORK(*) -- DIMENSION THIS INTEGER WORK ARRAY OF LENGTH LIW IN C YOUR CALLING PROGRAM. C C IWORK(1), IWORK(2) -- IF YOU HAVE SET INFO(6)=0, YOU CAN IGNORE C THESE OPTIONAL INPUT PARAMETERS. OTHERWISE YOU MUST DEFINE C THE HALF-BANDWIDTHS ML (LOWER) AND MU (UPPER) OF THE C JACOBIAN MATRIX BY SETTING IWORK(1) = ML AND C IWORK(2) = MU. (THE CODE WILL WORK WITH A FULL MATRIX C OF NEQ**2 ELEMENTS UNLESS IT IS TOLD THAT THE PROBLEM HAS C A BANDED JACOBIAN, IN WHICH CASE THE CODE WILL WORK WITH C A MATRIX CONTAINING AT MOST (2*ML+MU+1)*NEQ ELEMENTS.) C C LIW -- SET IT TO THE DECLARED LENGTH OF THE IWORK ARRAY. C YOU MUST HAVE LIW .GE. 55+NEQ. C C RPAR, IPAR -- THESE ARE PARAMETER ARRAYS, OF REAL AND INTEGER C TYPE, RESPECTIVELY. YOU CAN USE THEM FOR COMMUNICATION C BETWEEN YOUR PROGRAM THAT CALLS STFODE AND THE F C SUBROUTINE (AND THE JAC SUBROUTINE). THEY ARE NOT USED OR C ALTERED BY STFODE. IF YOU DO NOT NEED RPAR OR IPAR, IGNORE C THESE PARAMETERS BY TREATING THEM AS DUMMY ARGUMENTS. IF C YOU DO CHOOSE TO USE THEM, DIMENSION THEM IN YOUR CALLING C PROGRAM AND IN F (AND IN JAC) AS ARRAYS OF APPROPRIATE C LENGTH. C C JAC -- IF YOU HAVE SET INFO(5)=0, YOU CAN IGNORE THIS PARAMETER C BY TREATING IT AS A DUMMY ARGUMENT. (FOR SOME COMPILERS C YOU MAY HAVE TO WRITE A DUMMY SUBROUTINE NAMED JAC IN C ORDER TO AVOID PROBLEMS ASSOCIATED WITH MISSING EXTERNAL C ROUTINE NAMES.) OTHERWISE, YOU MUST PROVIDE A SUBROUTINE C OF THE FORM C JAC(X,U,PD,NROWPD,RPAR,IPAR) C TO DEFINE THE JACOBIAN MATRIX OF PARTIAL DERIVATIVES DF/DU C OF THE SYSTEM OF DIFFERENTIAL EQUATIONS DU/DX = F(X,U). C FOR THE GIVEN VALUES OF X AND THE VECTOR C U(*)=(U(1),U(2),...,U(NEQ)), THE SUBROUTINE MUST EVALUATE C THE NON-ZERO PARTIAL DERIVATIVES DF(I)/DU(J) FOR EACH C DIFFERENTIAL EQUATION I=1,...,NEQ AND EACH SOLUTION C COMPONENT J=1,...,NEQ , AND STORE THESE VALUES IN THE C MATRIX PD. THE ELEMENTS OF PD ARE SET TO ZERO BEFORE EACH C CALL TO JAC SO ONLY NON-ZERO ELEMENTS NEED TO BE DEFINED. C C SUBROUTINE JAC MUST NOT ALTER X, U(*), OR NROWPD. YOU MUST C DECLARE THE NAME JAC IN AN EXTERNAL STATEMENT IN YOUR C PROGRAM THAT CALLS STFODE. NROWPD IS THE ROW DIMENSION OF C THE PD MATRIX AND IS ASSIGNED BY THE CODE. THEREFORE YOU C MUST DIMENSION PD IN JAC ACCORDING TO C DIMENSION PD(NROWPD,1) C YOU MUST ALSO DIMENSION U IN JAC. C C THE WAY YOU MUST STORE THE ELEMENTS INTO THE PD MATRIX C DEPENDS ON THE STRUCTURE OF THE JACOBIAN WHICH YOU C INDICATED BY INFO(6). C *** INFO(6)=0 -- FULL (DENSE) JACOBIAN *** C WHEN YOU EVALUATE THE (NON-ZERO) PARTIAL DERIVATIVE C OF EQUATION I WITH RESPECT TO VARIABLE J, YOU MUST C STORE IT IN PD ACCORDING TO C PD(I,J) = * DF(I)/DU(J) * C *** INFO(6)=1 -- BANDED JACOBIAN WITH ML LOWER AND MU C UPPER DIAGONAL BANDS (REFER TO INFO(6) DESCRIPTION OF C ML AND MU) *** C WHEN YOU EVALUATE THE (NON-ZERO) PARTIAL DERIVATIVE C OF EQUATION I WITH RESPECT TO VARIABLE J, YOU MUST C STORE IT IN PD ACCORDING TO C IROW = I - J + ML + MU + 1 C PD(IROW,J) = * DF(I)/DU(J) * C C RPAR AND IPAR ARE REAL AND INTEGER PARAMETER ARRAYS WHICH C YOU CAN USE FOR COMMUNICATION BETWEEN YOUR CALLING C PROGRAM AND YOUR JACOBIAN SUBROUTINE JAC. THEY ARE NOT C ALTERED BY STFODE. IF YOU DO NOT NEED RPAR OR IPAR, IGNORE C THESE PARAMETERS BY TREATING THEM AS DUMMY ARGUMENTS. IF C YOU DO CHOOSE TO USE THEM, DIMENSION THEM IN YOUR CALLING C PROGRAM AND IN JAC AS ARRAYS OF APPROPRIATE LENGTH. C C*********************************************************************** C** OUTPUT -- AFTER ANY RETURN FROM STFODE ** C******************************************** C C THE PRINCIPAL AIM OF THE CODE IS TO RETURN A COMPUTED SOLUTION AT C TOUT, ALTHOUGH IT IS ALSO POSSIBLE TO OBTAIN INTERMEDIATE RESULTS C ALONG THE WAY. TO FIND OUT WHETHER THE CODE ACHIEVED ITS GOAL C OR IF THE INTEGRATION PROCESS WAS INTERRUPTED BEFORE THE TASK WAS C COMPLETED, YOU MUST CHECK THE IDID PARAMETER. C C C T -- THE SOLUTION WAS SUCCESSFULLY ADVANCED TO THE C OUTPUT VALUE OF T. C C Y(*) -- CONTAINS THE COMPUTED SOLUTION APPROXIMATION AT T. C YOU MAY ALSO BE INTERESTED IN THE APPROXIMATE DERIVATIVE C OF THE SOLUTION AT T. IT IS CONTAINED IN C RWORK(21),...,RWORK(20+NEQ). C C IDID -- REPORTS WHAT THE CODE DID C C *** TASK COMPLETED *** C REPORTED BY POSITIVE VALUES OF IDID C C IDID = 1 -- A STEP WAS SUCCESSFULLY TAKEN IN THE C INTERMEDIATE-OUTPUT MODE. THE CODE HAS NOT C YET REACHED TOUT. C C IDID = 2 -- THE INTEGRATION TO TOUT WAS SUCCESSFULLY C COMPLETED (T=TOUT) BY STEPPING EXACTLY TO TOUT. C C IDID = 3 -- THE INTEGRATION TO TOUT WAS SUCCESSFULLY C COMPLETED (T=TOUT) BY STEPPING PAST TOUT. C Y(*) IS OBTAINED BY INTERPOLATION. C C *** TASK INTERRUPTED *** C REPORTED BY NEGATIVE VALUES OF IDID C C IDID = -1 -- A LARGE AMOUNT OF WORK HAS BEEN EXPENDED. C (500 STEPS PERFORMED) C C IDID = -2 -- THE ERROR TOLERANCES ARE TOO STRINGENT. C C IDID = -3 -- THE LOCAL ERROR TEST CANNOT BE SATISFIED C SINCE THE L-TH SOLUTION COMPONENT IS 0 AND C THE CORRESPONDING ABSOLUTE ERROR TOLERANCE C IS 0 FOR L = -INFO(1). A PURE RELATIVE ERROR C TEST CANNOT BE APPLIED TO THIS COMPONENT. C C IDID = -4,-5 -- NOT APPLICABLE FOR THIS CODE. C C IDID = -6 -- STFODE HAD REPEATED CONVERGENCE TEST FAILURES C ON THE LAST ATTEMPTED STEP. C C IDID = -7 -- STFODE HAD REPEATED ERROR TEST FAILURES ON C THE LAST ATTEMPTED STEP. C C IDID = -8,..,-32 -- NOT APPLICABLE FOR THIS CODE. C C *** TASK TERMINATED *** C REPORTED BY THE VALUE OF IDID .LE. -33 C C IDID = -33 -- NEQ .LT. 1 C C IDID = -34 -- RTOL(K) .LT. 0 FOR SOME K C C IDID = -35 -- ATOL(K) .LT. 0 FOR SOME K C C IDID = -36 -- THE CODE HAS BEEN CALLED WITH TOUT BUT C THE CODE HAS ALSO BEEN TOLD NOT TO INTEGRATE C PAST THE POINT TSTOP. C C IDID = -37 -- THE CODE HAS BEEN CALLED WITH T = TOUT. C THIS IS NOT PERMITTED ON CONTINUATION CALLS. C C IDID = -38 -- THE USER HAS MODIFIED THE VALUE OF T. C THIS IS NOT PERMITTED ON CONTINUATION CALLS. C C IDID = -39 -- BY CALLING THE CODE WITH TOUT, AN C ATTEMPT IS BEING MADE TO CHANGE THE DIRECTION C OF INTEGRATION WITHOUT RESTARTING. C C IDID = -40 -- THE JACOBIAN MATRIX IS BANDED. HOWEVER C THE BANDWIDTHS ML AND MU DO NOT SATISFY THE C CONSTRAINTS 0 .LE. ML,MU .LT. NEQ. C C IDID = -41 -- LRW .LT. 250 + 10*NEQ + NEQ*NEQ C C IDID = -42 -- LRW .LT. 250 + 10*NEQ + (2*ML+MU+1)*NEQ C C IDID = -43 -- LIW .LT. 55 + NEQ C C IDID = -44 -- INFO(1) IS INCORRECT. C C RTOL, ATOL -- THESE QUANTITIES REMAIN UNCHANGED EXCEPT WHEN C IDID = -2. IN THIS CASE, THE ERROR TOLERANCES HAVE BEEN C INCREASED BY THE CODE TO VALUES WHICH ARE ESTIMATED TO BE C APPROPRIATE FOR CONTINUING THE INTEGRATION. HOWEVER, THE C REPORTED SOLUTION AT T WAS OBTAINED USING THE INPUT VALUES C OF RTOL AND ATOL. C C RWORK, IWORK -- CONTAIN INFORMATION WHICH IS USUALLY OF NO C INTEREST TO THE USER BUT NECESSARY FOR SUBSEQUENT CALLS. C HOWEVER, YOU MAY FIND USE FOR C C RWORK(11)--WHICH CONTAINS THE STEP SIZE H TO BE C ATTEMPTED ON THE NEXT STEP. C C RWORK(12)--IF THE TOLERANCES HAVE BEEN INCREASED BY THE C CODE (IDID = -2) , THEY WERE MULTIPLIED BY THE C VALUE IN RWORK(12). C C RWORK(13)--WHICH CONTAINS THE CURRENT VALUE OF THE C INDEPENDENT VARIABLE, I.E. THE FARTHEST POINT C INTEGRATION HAS REACHED. THIS WILL BE DIFFERENT C FROM T ONLY WHEN INTERPOLATION HAS BEEN C PERFORMED (IDID=3). C C RWORK(20+I)--WHICH CONTAINS THE APPROXIMATE DERIVATIVE C OF THE SOLUTION COMPONENT Y(I). IN STFODE IT IS C NEVER OBTAINED BY CALLING SUBROUTINE F TO C EVALUATE THE DIFFERENTIAL EQUATION USING T AND C Y(*), EXCEPT AT THE INITIAL POINT OF C INTEGRATION. C C*********************************************************************** C** INPUT -- WHAT TO DO TO CONTINUE THE INTEGRATION ** C** (CALLS AFTER THE FIRST) ** C***************************************************** C C THIS CODE IS ORGANIZED SO THAT SUBSEQUENT CALLS TO CONTINUE THE C INTEGRATION INVOLVE LITTLE (IF ANY) ADDITIONAL EFFORT ON YOUR C PART. YOU MUST MONITOR THE IDID PARAMETER IN ORDER TO DETERMINE C WHAT TO DO NEXT. C C RECALLING THAT THE PRINCIPAL TASK OF THE CODE IS TO INTEGRATE C FROM T TO TOUT (THE INTERVAL MODE), USUALLY ALL YOU WILL NEED C TO DO IS SPECIFY A NEW TOUT UPON REACHING THE CURRENT TOUT. C C DO NOT ALTER ANY QUANTITY NOT SPECIFICALLY PERMITTED BELOW, C IN PARTICULAR DO NOT ALTER NEQ, T, Y(*), RWORK(*), IWORK(*) OR C THE DIFFERENTIAL EQUATION IN SUBROUTINE F. ANY SUCH ALTERATION C CONSTITUTES A NEW PROBLEM AND MUST BE TREATED AS SUCH, I.E. C YOU MUST START AFRESH. C C YOU CANNOT CHANGE FROM VECTOR TO SCALAR ERROR CONTROL OR VICE C VERSA (INFO(2)) BUT YOU CAN CHANGE THE SIZE OF THE ENTRIES OF C RTOL, ATOL. INCREASING A TOLERANCE MAKES THE EQUATION EASIER C TO INTEGRATE. DECREASING A TOLERANCE WILL MAKE THE EQUATION C HARDER TO INTEGRATE AND SHOULD GENERALLY BE AVOIDED. C C YOU CAN SWITCH FROM THE INTERMEDIATE-OUTPUT MODE TO THE C INTERVAL MODE (INFO(3)) OR VICE VERSA AT ANY TIME. C C IF IT HAS BEEN NECESSARY TO PREVENT THE INTEGRATION FROM GOING C PAST A POINT TSTOP (INFO(4), RWORK(1)), KEEP IN MIND THAT THE C CODE WILL NOT INTEGRATE TO ANY TOUT BEYOND THE CURRENTLY C SPECIFIED TSTOP. ONCE TSTOP HAS BEEN REACHED YOU MUST CHANGE C THE VALUE OF TSTOP OR SET INFO(4)=0. YOU MAY CHANGE INFO(4) C OR TSTOP AT ANY TIME BUT YOU MUST SUPPLY THE VALUE OF TSTOP IN C RWORK(1) WHENEVER YOU SET INFO(4)=1. C C DO NOT CHANGE INFO(5), INFO(6), IWORK(1), OR IWORK(2) C UNLESS YOU ARE GOING TO RESTART THE CODE. C C THE PARAMETER INFO(1) IS USED BY THE CODE TO INDICATE THE C BEGINNING OF A NEW PROBLEM AND TO INDICATE WHETHER INTEGRATION C IS TO BE CONTINUED. YOU MUST INPUT THE VALUE INFO(1) = 0 C WHEN STARTING A NEW PROBLEM. YOU MUST INPUT THE VALUE C INFO(1) = 1 IF YOU WISH TO CONTINUE AFTER AN INTERRUPTED TASK C FOR WHICH IDID = -3, -6, OR -7. DO NOT SET INFO(1) = 0 ON A C CONTINUATION CALL UNLESS YOU WANT THE CODE TO RESTART AT THE C CURRENT T. C C *** FOLLOWING A COMPLETED TASK *** C IF C IDID = 1, CALL THE CODE AGAIN TO CONTINUE THE INTEGRATION C ANOTHER STEP IN THE DIRECTION OF TOUT. C C IDID = 2 OR 3, DEFINE A NEW TOUT AND CALL THE CODE AGAIN. C TOUT MUST BE DIFFERENT FROM T. YOU CANNOT CHANGE C THE DIRECTION OF INTEGRATION WITHOUT RESTARTING. C C *** FOLLOWING AN INTERRUPTED TASK *** C IF C IDID = -1, THE CODE HAS PERFORMED 500 STEPS. C IF YOU WANT TO CONTINUE, CALL THE CODE AGAIN. C C IDID = -2, THE ERROR TOLERANCES RTOL AND ATOL HAVE BEEN C INCREASED TO VALUES THE CODE ESTIMATES APPROPRIATE C FOR CONTINUING. YOU MAY WANT TO CHANGE THEM C YOURSELF. IF YOU WANT TO CONTINUE, CALL THE CODE C AGAIN. C C IDID = -3, THE L-TH SOLUTION COMPONENT IS 0 AND THE C CORRESPONDING ABSOLUTE ERROR TOLERANCE IS 0 C FOR L = -INFO(1). TO CONTINUE, RESET THE C ABSOLUTE TOLERANCE TO A POSITIVE VALUE, SET C INFO(1) = 1, AND CALL THE CODE AGAIN. C C IDID = -4,-5 --- CANNOT OCCUR WITH THIS CODE. C C IDID = -6, REPEATED CONVERGENCE TEST FAILURES OCCURRED C ON THE LAST ATTEMPTED STEP. AN INACCURATE C JACOBIAN MAY BE THE PROBLEM. IF YOU ARE ABSOLUTELY C CERTAIN YOU WANT TO CONTINUE, RESTART THE C INTEGRATION AT THE CURRENT T BY SETTING INFO(1)=0 C AND CALL THE CODE AGAIN. C C IDID = -7, REPEATED ERROR TEST FAILURES OCCURRED ON THE C LAST ATTEMPTED STEP. A SINGULARITY IN THE C SOLUTION MAY BE PRESENT. YOU SHOULD RE-EXAMINE THE C PROBLEM BEING SOLVED. IF YOU ARE ABSOLUTELY C CERTAIN YOU WANT TO CONTINUE, RESTART THE C INTEGRATION AT THE CURRENT T BY SETTING INFO(1)=0 C AND CALL THE CODE AGAIN. C C IDID = -8,..,-32 --- CANNOT OCCUR WITH THIS CODE. C C *** FOLLOWING A TERMINATED TASK *** C IF C IDID .LE. -33, AN INPUT ERROR HAS BEEN DETECTED. AFTER THE C ERROR IS CORRECTED, RESTART BY SETTING INFO(1) = 0 C AND CALL THE CODE AGAIN. C C*********************************************************************** C C ***** WARNING ***** C C IF STFODE IS TO BE USED IN AN OVERLAY SITUATION, YOU MUST SAVE AND C RESTORE CERTAIN ITEMS USED INTERNALLY BY STFODE (VALUES IN THE C COMMON BLOCK DEBDF1). THIS CAN BE ACCOMPLISHED AS FOLLOWS. C C TO SAVE THE NECESSARY VALUES UPON RETURN FROM STFODE, SIMPLY CALL C SVCO(RWORK(22+NEQ),IWORK(21+NEQ)). C C TO RESTORE THE NECESSARY VALUES BEFORE THE NEXT CALL TO STFODE, C SIMPLY CALL RSCO(RWORK(22+NEQ),IWORK(21+NEQ)). C C*********************************************************************** C C***REFERENCES C SHAMPINE L.F., WATTS H.A., *DEPAC - DESIGN OF A USER ORIENTED C PACKAGE OF ODE SOLVERS*, SAND79-2374, SANDIA LABORATORIES, 1979. C C LOGICAL INTOUT C DIMENSION Y(NEQ),INFO( *),RTOL(*),ATOL(*),RWORK(LRW),IWORK(LIW), 1 RPAR(*),IPAR(*) C COMMON /DEBDF1/ TOLD, ROWNS(210), 1 EL0, H, HMIN, HMXI, HU, TN, UROUND, 2 IQUIT, INIT, IYH, IEWT, IACOR, ISAVF, IWM, KSTEPS, 3 IBEGIN, ITOL, IINTEG, ITSTOP, IJAC, IBAND, IOWNS(6), 4 IER, JSTART, KFLAG, L, METH, MITER, MAXORD, N, NQ, NST, NFE, 5 NJE, NQU C EXTERNAL F , JAC C C....................................................................... C IDID = 0 C IF (INFO(1) .EQ. 0) GO TO 20 IF (INFO(1) .NE. 1) GO TO 10 IF (IQUIT .EQ. 0) GO TO 20 10 IDID = -44 RETURN C 20 IF (INFO(2) .NE. 0) INFO(2) = 1 IF (INFO(3) .NE. 0) INFO(3) = 1 IF (INFO(4) .NE. 0) INFO(4) = 1 IF (INFO(5) .NE. 0) INFO(5) = 1 IF (INFO(6) .NE. 0) INFO(6) = 1 C ILRW = NEQ IF (INFO(6) .EQ. 0) GO TO 80 C C CHECK BANDWIDTH PARAMETERS C ML = IWORK(1) MU = IWORK(2) ILRW = 2*ML + MU + 1 IF (ML .GE. 0 .AND. ML .LT. NEQ .AND. 1 MU .GE. 0 .AND. MU .LT. NEQ) GO TO 80 IDID = -40 RETURN C C CHECK LRW AND LIW FOR SUFFICIENT STORAGE ALLOCATION C 80 IF (LRW .GE. 250+(10+ILRW)*NEQ) GO TO 100 C IF (INFO(6) .EQ. 1) GO TO 90 IDID = -41 RETURN C 90 IDID = -42 RETURN C 100 IF (LIW .GE. 55+NEQ) GO TO 200 IDID = -43 RETURN C C COMPUTE THE INDICES FOR THE ARRAYS TO BE STORED IN THE WORK ARRAY C AND RESTORE COMMON BLOCK DATA C 200 ICOMI = 21 + NEQ IINOUT = ICOMI + 33 C IYPOUT = 21 ITSTAR = 21 + NEQ ICOMR = 22 + NEQ C IF (INFO(1) .EQ. 0) GO TO 250 INTOUT = IWORK(IINOUT) .NE. (-1) C CALL RSCO(RWORK(ICOMR),IWORK(ICOMI)) C 250 IYH = ICOMR + 218 IEWT = IYH + 6*NEQ ISAVF = IEWT + NEQ IACOR = ISAVF + NEQ IWM = IACOR + NEQ IDELSN = IWM + 2+ILRW*NEQ C IBEGIN = INFO(1) ITOL = INFO(2) IINTEG = INFO(3) ITSTOP = INFO(4) IJAC = INFO(5) IBAND = INFO(6) RWORK(ITSTAR) = T C CALL LSOD1(F,NEQ,T,Y,TOUT,RTOL,ATOL,IDID,RWORK(IYPOUT), 1 RWORK(IYH),RWORK(IYH),RWORK(IEWT),RWORK(ISAVF), 2 RWORK(IACOR),RWORK(IWM),IWORK(1),JAC,INTOUT, 3 RWORK(1),RWORK(12),RWORK(IDELSN),RPAR,IPAR) C IWORK(IINOUT) = -1 IF (INTOUT) IWORK(IINOUT) = 1 C C CALL SVCO(RWORK(ICOMR),IWORK(ICOMI)) RWORK(11) = H RWORK(13) = TN INFO(1) = IBEGIN C RETURN END SUBROUTINE RSCO (RSAV, ISAV) C----------------------------------------------------------------------- C THIS ROUTINE RESTORES FROM RSAV AND ISAV THE CONTENTS OF COMMON C BLOCK DEBDF1, WHICH IS USED INTERNALLY IN THE SFODE PACKAGE. C----------------------------------------------------------------------- INTEGER ISAV, I, ILS, LENILS, LENRLS REAL RSAV, RLS DIMENSION RSAV(*), ISAV(*) COMMON /DEBDF1/ RLS(218), ILS(33) DATA LENRLS/218/, LENILS/33/ C DO 10 I = 1,LENRLS 10 RLS(I) = RSAV(I) DO 20 I = 1,LENILS 20 ILS(I) = ISAV(I) RETURN C----------------------- END OF SUBROUTINE RSCO ----------------------- END SUBROUTINE SVCO (RSAV, ISAV) C----------------------------------------------------------------------- C THIS ROUTINE STORES IN RSAV AND ISAV THE CONTENTS OF COMMON BLOCK C DEBDF1, WHICH IS USED INTERNALLY IN THE SFODE PACKAGE. C C RSAV = REAL ARRAY OF LENGTH 218 OR MORE. C ISAV = INTEGER ARRAY OF LENGTH 33 OR MORE. C----------------------------------------------------------------------- INTEGER ISAV, I, ILS, LENILS, LENRLS REAL RSAV, RLS DIMENSION RSAV(*), ISAV(*) COMMON /DEBDF1/ RLS(218), ILS(33) DATA LENRLS/218/, LENILS/33/ C DO 10 I = 1,LENRLS 10 RSAV(I) = RLS(I) DO 20 I = 1,LENILS 20 ISAV(I) = ILS(I) RETURN C----------------------- END OF SUBROUTINE SVCO ----------------------- END SUBROUTINE LSOD1 (F,NEQ,T,Y,TOUT,RTOL,ATOL,IDID,YPOUT, 1 YH,YH1,EWT,SAVF,ACOR,WM,IWM,JAC,INTOUT, 2 TSTOP,TOLFAC,DELSGN,RPAR,IPAR) C C STFODE MERELY ALLOCATES STORAGE FOR LSOD1 TO RELIEVE THE USER OF C THE INCONVENIENCE OF A LONG CALL LIST. CONSEQUENTLY LSOD1 IS USED C AS DESCRIBED IN THE COMMENTS FOR STFODE. C C***ROUTINES CALLED STOD,INTYD,VNWRMS,HSTART,SPMPAR C LOGICAL INTOUT C DIMENSION Y(NEQ),YPOUT(NEQ),YH(NEQ,*),YH1(*),EWT(NEQ),SAVF(NEQ), 1 ACOR(NEQ),WM(*),IWM(*),RTOL(*),ATOL(*),RPAR(*),IPAR(*) C COMMON /DEBDF1/ TOLD, ROWNS(210), 1 EL0, H, HMIN, HMXI, HU, X, U, 2 IQUIT, INIT, LYH, LEWT, LACOR, LSAVF, LWM, KSTEPS, 3 IBEGIN, ITOL, IINTEG, ITSTOP, IJAC, IBAND, IOWNS(6), 4 IER, JSTART, KFLAG, LDUM, METH, MITER, MAXORD, N, NQ, NST, 5 NFE, NJE, NQU C EXTERNAL F , JAC C C....................................................................... C C THE EXPENSE OF SOLVING THE PROBLEM IS MONITORED BY COUNTING THE C NUMBER OF STEPS ATTEMPTED. WHEN THIS EXCEEDS MAXNUM, THE COUNTER C IS RESET TO ZERO AND THE USER IS INFORMED ABOUT POSSIBLE EXCESSIVE C WORK. C DATA MAXNUM/500/ C C....................................................................... C IF (IBEGIN .NE. 0) GO TO 10 C C ON THE FIRST CALL , PERFORM INITIALIZATION -- C DEFINE THE MACHINE UNIT ROUNDOFF QUANTITY U BY CALLING THE C FUNCTION ROUTINE SPMPAR. THE USER MUST MAKE SURE THAT THE C VALUES SET IN SPMPAR ARE RELEVANT TO THE COMPUTER BEING USED. C U=SPMPAR(1) C -- SET ASSOCIATED MACHINE DEPENDENT PARAMETER WM(1)=SQRT(U) C -- SET TERMINATION FLAG IQUIT=0 C -- SET INITIALIZATION INDICATOR INIT=0 C -- SET COUNTER FOR ATTEMPTED STEPS KSTEPS=0 C -- SET INDICATOR FOR INTERMEDIATE-OUTPUT INTOUT= .FALSE. C -- SET START INDICATOR FOR STOD CODE JSTART= 0 C -- SET BDF METHOD INDICATOR METH = 2 C -- SET MAXIMUM ORDER FOR BDF METHOD MAXORD = 5 C -- SET ITERATION MATRIX INDICATOR C IF (IJAC .EQ. 0 .AND. IBAND .EQ. 0) MITER = 2 IF (IJAC .EQ. 1 .AND. IBAND .EQ. 0) MITER = 1 IF (IJAC .EQ. 0 .AND. IBAND .EQ. 1) MITER = 5 IF (IJAC .EQ. 1 .AND. IBAND .EQ. 1) MITER = 4 C C -- SET OTHER NECESSARY ITEMS IN COMMON BLOCK N = NEQ NST = 0 NJE = 0 HMXI = 0. NQ = 1 H = 1. C -- RESET IBEGIN FOR SUBSEQUENT CALLS IBEGIN = 1 C C....................................................................... C C CHECK VALIDITY OF INPUT PARAMATERS ON EACH ENTRY C 10 IF (NEQ .GE. 1) GO TO 20 IDID = -33 GO TO 110 C 20 MAX = 1 IF (ITOL .NE. 0) MAX = NEQ DO 60 K = 1,MAX IF (RTOL(K) .GE. 0.) GO TO 30 IDID = -34 GO TO 110 30 IF (ATOL(K) .GE. 0.) GO TO 60 IDID = -35 GO TO 110 60 CONTINUE C IF (ITSTOP .NE. 1) GO TO 80 IF ((TOUT - T)*(TSTOP - T) .GE. 0.0 1 .AND. ABS(TOUT-T) .LE. ABS(TSTOP-T)) GO TO 80 IDID = -36 GO TO 110 C 80 IF (INIT .EQ. 0) GO TO 150 C CHECK SOME CONTINUATION POSSIBILITIES IF (T .NE. TOUT) GO TO 90 IDID = -37 GO TO 110 C 90 IF (T .EQ. TOLD) GO TO 100 IDID = -38 GO TO 110 C 100 IF (INIT .EQ. 1) GO TO 150 IF (DELSGN*(TOUT-T) .GE. 0.) GO TO 150 IDID = -39 C C INVALID INPUT DETECTED 110 IQUIT = -33 IBEGIN = -1 RETURN C C....................................................................... C C RTOL = ATOL = 0. IS ALLOWED AS VALID INPUT AND INTERPRETED AS C ASKING FOR THE MOST ACCURATE SOLUTION POSSIBLE. IN THIS CASE, C THE RELATIVE ERROR TOLERANCE RTOL IS RESET TO THE SMALLEST VALUE C 100*U WHICH IS LIKELY TO BE REASONABLE FOR THIS METHOD AND MACHINE C 150 DO 170 K = 1,MAX IF (RTOL(K) + ATOL(K) .GT. 0.) GO TO 170 RTOL(K) = 100.*U IDID = -2 170 CONTINUE IF (IDID .EQ. -2) RETURN C C BRANCH ON STATUS OF INITIALIZATION INDICATOR C INIT=0 MEANS INITIAL DERIVATIVES AND NOMINAL STEP SIZE C AND DIRECTION NOT YET SET C INIT=1 MEANS NOMINAL STEP SIZE AND DIRECTION NOT YET SET C INIT=2 MEANS NO FUTHER INITIALIZATION REQUIRED C IF (INIT .EQ. 0) GO TO 200 IF (INIT .EQ. 1) GO TO 220 GO TO 240 C C....................................................................... C C MORE INITIALIZATION -- C -- EVALUATE INITIAL DERIVATIVES C 200 INIT = 1 CALL F(T,Y,YH(1,2),RPAR,IPAR) NFE = 1 IF (T .NE. TOUT) GO TO 220 IDID = 2 DO 210 L = 1,NEQ 210 YPOUT(L) = YH(L,2) TOLD = T RETURN C C -- COMPUTE INITIAL STEP SIZE C -- SAVE SIGN OF INTEGRATION DIRECTION C -- SET INDEPENDENT AND DEPENDENT VARIABLES C X AND YH(*) FOR STOD C 220 LTOL = 1 DO 225 L = 1,NEQ IF (ITOL .EQ. 1) LTOL = L TOL = RTOL(LTOL)*ABS(Y(L)) + ATOL(LTOL) IF (TOL .EQ. 0.) GO TO 380 225 EWT(L) = TOL C BIG = SQRT(SPMPAR(3)) CALL HSTART (F,NEQ,T,TOUT,Y,YH(1,2),EWT,1,U,BIG, 1 YH(1,3),YH(1,4),YH(1,5),YH(1,6),RPAR,IPAR,H) C DELSGN = SIGN(1.0,TOUT-T) X = T DO 230 L = 1,NEQ YH(L,1) = Y(L) 230 YH(L,2) = H*YH(L,2) INIT = 2 C C....................................................................... C C ON EACH CALL SET INFORMATION WHICH DETERMINES THE ALLOWED INTERVAL C OF INTEGRATION BEFORE RETURNING WITH AN ANSWER AT TOUT C 240 DEL = TOUT - T ABSDEL = ABS(DEL) C C....................................................................... C C IF ALREADY PAST OUTPUT POINT, INTERPOLATE AND RETURN C 250 IF (ABS(X-T) .LT. ABSDEL) GO TO 270 CALL INTYD(TOUT,0,YH,NEQ,Y,INTFLG) CALL INTYD(TOUT,1,YH,NEQ,YPOUT,INTFLG) IDID = 3 IF (X .NE. TOUT) GO TO 260 IDID = 2 INTOUT = .FALSE. 260 T = TOUT TOLD = T RETURN C C IF CANNOT GO PAST TSTOP AND SUFFICIENTLY CLOSE, C EXTRAPOLATE AND RETURN C 270 IF (ITSTOP .NE. 1) GO TO 290 IF (ABS(TSTOP-X) .GE. 100.*U*ABS(X)) GO TO 290 DT = TOUT - X DO 280 L = 1,NEQ 280 Y(L) = YH(L,1) + (DT/H)*YH(L,2) CALL F(TOUT,Y,YPOUT,RPAR,IPAR) NFE = NFE + 1 IDID = 3 T = TOUT TOLD = T RETURN C 290 IF (IINTEG .EQ. 0 .OR. .NOT.INTOUT) GO TO 300 C C INTERMEDIATE-OUTPUT MODE C IDID = 1 GO TO 500 C C....................................................................... C C MONITOR NUMBER OF STEPS ATTEMPTED C 300 IF (KSTEPS .LE. MAXNUM) GO TO 330 C C A SIGNIFICANT AMOUNT OF WORK HAS BEEN EXPENDED IDID = -1 KSTEPS = 0 GO TO 500 C C....................................................................... C C LIMIT STEP SIZE AND SET WEIGHT VECTOR C 330 HMIN = 100.*U*ABS(X) HA = AMAX1(ABS(H),HMIN) IF (ITSTOP .NE. 1) GO TO 340 HA = AMIN1(HA,ABS(TSTOP-X)) 340 H = SIGN(HA,H) LTOL = 1 DO 350 L = 1,NEQ IF (ITOL .EQ. 1) LTOL = L EWT(L) = RTOL(LTOL)*ABS(YH(L,1)) + ATOL(LTOL) IF (EWT(L) .LE. 0.0) GO TO 380 350 CONTINUE TOLFAC = U*VNWRMS(NEQ,YH,EWT) IF (TOLFAC .LE. 1.) GO TO 400 C C TOLERANCES TOO SMALL IDID = -2 TOLFAC = 2.*TOLFAC DO 360 L = 1,MAX RTOL(L) = TOLFAC*RTOL(L) 360 ATOL(L) = TOLFAC*ATOL(L) GO TO 500 C C RELATIVE ERROR CRITERION INAPPROPRIATE 380 IDID = -3 IBEGIN = -L GO TO 500 C C....................................................................... C C TAKE A STEP C 400 CALL STOD(NEQ,Y,YH,NEQ,YH1,EWT,SAVF,ACOR,WM,IWM,F,JAC,RPAR,IPAR) C JSTART = -2 INTOUT = .TRUE. IF (KFLAG .EQ. 0) GO TO 250 C C....................................................................... C IF (KFLAG .EQ. -1) GO TO 450 C C REPEATED CORRECTOR CONVERGENCE FAILURES IDID = -6 IQUIT = -6 IBEGIN = -1 GO TO 500 C C REPEATED ERROR TEST FAILURES 450 IDID = -7 IQUIT = -7 IBEGIN = -1 C C....................................................................... C C STORE VALUES BEFORE RETURNING TO STFODE 500 DO 555 L = 1,NEQ Y(L) = YH(L,1) 555 YPOUT(L) = YH(L,2)/H T = X TOLD = T INTOUT = .FALSE. RETURN END SUBROUTINE HSTART(F,NEQ,A,B,Y,YPRIME,ETOL,MORDER,SMALL,BIG, 1 SPY,PV,YP,SF,RPAR,IPAR,H) C C HSTART COMPUTES A STARTING STEP SIZE TO BE USED IN SOLVING INITIAL C VALUE PROBLEMS IN ORDINARY DIFFERENTIAL EQUATIONS. C C C*********************************************************************** C ABSTRACT C C SUBROUTINE HSTART COMPUTES A STARTING STEP SIZE TO BE USED BY AN C INITIAL VALUE METHOD IN SOLVING ORDINARY DIFFERENTIAL EQUATIONS. C IT IS BASED ON AN ESTIMATE OF THE LOCAL LIPSCHITZ CONSTANT FOR THE C DIFFERENTIAL EQUATION (LOWER BOUND ON A NORM OF THE JACOBIAN) , C A BOUND ON THE DIFFERENTIAL EQUATION (FIRST DERIVATIVE) , AND C A BOUND ON THE PARTIAL DERIVATIVE OF THE EQUATION WITH RESPECT TO C THE INDEPENDENT VARIABLE. C (ALL APPROXIMATED NEAR THE INITIAL POINT A) C C SUBROUTINE HSTART USES A FUNCTION SUBPROGRAM VNORM FOR COMPUTING C A VECTOR NORM. THE MAXIMUM NORM IS PRESENTLY UTILIZED THOUGH IT C CAN EASILY BE REPLACED BY ANY OTHER VECTOR NORM. IT IS PRESUMED C THAT ANY REPLACEMENT NORM ROUTINE WOULD BE CAREFULLY CODED TO C PREVENT UNNECESSARY UNDERFLOWS OR OVERFLOWS FROM OCCURRING, AND C ALSO, WOULD NOT ALTER THE VECTOR OR NUMBER OF COMPONENTS. C C*********************************************************************** C ON INPUT YOU MUST PROVIDE THE FOLLOWING C C F -- THIS IS A SUBROUTINE OF THE FORM C F(X,U,UPRIME,RPAR,IPAR) C WHICH DEFINES THE SYSTEM OF FIRST ORDER DIFFERENTIAL C EQUATIONS TO BE SOLVED. FOR THE GIVEN VALUES OF X AND THE C VECTOR U(*)=(U(1),U(2),...,U(NEQ)) , THE SUBROUTINE MUST C EVALUATE THE NEQ COMPONENTS OF THE SYSTEM OF DIFFERENTIAL C EQUATIONS DU/DX=F(X,U) AND STORE THE DERIVATIVES IN THE C ARRAY UPRIME(*), THAT IS, UPRIME(I) = * DU(I)/DX * FOR C EQUATIONS I=1,...,NEQ. C C SUBROUTINE F MUST NOT ALTER X OR U(*). YOU MUST DECLARE C THE NAME F IN AN EXTERNAL STATEMENT IN YOUR PROGRAM THAT C CALLS HSTART. YOU MUST DIMENSION U AND UPRIME IN F. C C RPAR AND IPAR ARE REAL AND INTEGER PARAMETER ARRAYS WHICH C YOU CAN USE FOR COMMUNICATION BETWEEN YOUR PROGRAM AND C SUBROUTINE F. THEY ARE NOT USED OR ALTERED BY HSTART. IF C YOU DO NOT NEED RPAR OR IPAR, IGNORE THESE PARAMETERS BY C TREATING THEM AS DUMMY ARGUMENTS. IF YOU DO CHOOSE TO USE C THEM, DIMENSION THEM IN YOUR PROGRAM AND IN F AS ARRAYS C OF APPROPRIATE LENGTH. C C NEQ -- THIS IS THE NUMBER OF (FIRST ORDER) DIFFERENTIAL EQUATIONS C TO BE INTEGRATED. C C A -- THIS IS THE INITIAL POINT OF INTEGRATION. C C B -- THIS IS A VALUE OF THE INDEPENDENT VARIABLE USED TO DEFINE C THE DIRECTION OF INTEGRATION. A REASONABLE CHOICE IS TO C SET B TO THE FIRST POINT AT WHICH A SOLUTION IS DESIRED. C YOU CAN ALSO USE B, IF NECESSARY, TO RESTRICT THE LENGTH C OF THE FIRST INTEGRATION STEP BECAUSE THE ALGORITHM WILL C NOT COMPUTE A STARTING STEP LENGTH WHICH IS BIGGER THAN C ABS(B-A), UNLESS B HAS BEEN CHOSEN TOO CLOSE TO A. C (IT IS PRESUMED THAT HSTART HAS BEEN CALLED WITH B C DIFFERENT FROM A ON THE MACHINE BEING USED. ALSO SEE THE C DISCUSSION ABOUT THE PARAMETER SMALL.) C C Y(*) -- THIS IS THE VECTOR OF INITIAL VALUES OF THE NEQ SOLUTION C COMPONENTS AT THE INITIAL POINT A. C C YPRIME(*) -- THIS IS THE VECTOR OF DERIVATIVES OF THE NEQ C SOLUTION COMPONENTS AT THE INITIAL POINT A. C (DEFINED BY THE DIFFERENTIAL EQUATIONS IN SUBROUTINE F) C C ETOL -- THIS IS THE VECTOR OF ERROR TOLERANCES CORRESPONDING TO C THE NEQ SOLUTION COMPONENTS. IT IS ASSUMED THAT ALL C ELEMENTS ARE POSITIVE. FOLLOWING THE FIRST INTEGRATION C STEP, THE TOLERANCES ARE EXPECTED TO BE USED BY THE C INTEGRATOR IN AN ERROR TEST WHICH ROUGHLY REQUIRES THAT C ABS(LOCAL ERROR) .LE. ETOL C FOR EACH VECTOR COMPONENT. C C MORDER -- THIS IS THE ORDER OF THE FORMULA WHICH WILL BE USED BY C THE INITIAL VALUE METHOD FOR TAKING THE FIRST INTEGRATION C STEP. C C SMALL -- THIS IS A SMALL POSITIVE MACHINE DEPENDENT CONSTANT C WHICH IS USED FOR PROTECTING AGAINST COMPUTATIONS WITH C NUMBERS WHICH ARE TOO SMALL RELATIVE TO THE PRECISION OF C FLOATING POINT ARITHMETIC. SMALL SHOULD BE SET TO C (APPROXIMATELY) THE SMALLEST POSITIVE REAL NUMBER SUCH C THAT (1.+SMALL) .GT. 1. ON THE MACHINE BEING USED. THE C QUANTITY SMALL**(3/8) IS USED IN COMPUTING INCREMENTS OF C VARIABLES FOR APPROXIMATING DERIVATIVES BY DIFFERENCES. C ALSO THE ALGORITHM WILL NOT COMPUTE A STARTING STEP LENGTH C WHICH IS SMALLER THAN 100*SMALL*ABS(A). C C BIG -- THIS IS A LARGE POSITIVE MACHINE DEPENDENT CONSTANT WHICH C IS USED FOR PREVENTING MACHINE OVERFLOWS. A REASONABLE C CHOICE IS TO SET BIG TO (APPROXIMATELY) THE SQUARE ROOT OF C THE LARGEST REAL NUMBER WHICH CAN BE HELD IN THE MACHINE. C C SPY(*),PV(*),YP(*),SF(*) -- THESE ARE REAL WORK ARRAYS OF LENGTH C NEQ WHICH PROVIDE THE ROUTINE WITH NEEDED STORAGE SPACE. C C RPAR,IPAR -- THESE ARE PARAMETER ARRAYS, OF REAL AND INTEGER C TYPE, RESPECTIVELY, WHICH CAN BE USED FOR COMMUNICATION C BETWEEN YOUR PROGRAM AND THE F SUBROUTINE. THEY ARE NOT C USED OR ALTERED BY HSTART. C C*********************************************************************** C ON OUTPUT (AFTER THE RETURN FROM HSTART), C C H -- IS AN APPROPRIATE STARTING STEP SIZE TO BE ATTEMPTED BY THE C DIFFERENTIAL EQUATION METHOD. C C ALL PARAMETERS IN THE CALL LIST REMAIN UNCHANGED EXCEPT FOR C THE WORKING ARRAYS SPY(*),PV(*),YP(*), AND SF(*). C C*********************************************************************** C C***ROUTINES CALLED VNORM C DIMENSION Y(NEQ),YPRIME(NEQ),ETOL(NEQ), 1 SPY(NEQ),PV(NEQ),YP(NEQ),SF(NEQ),RPAR(*),IPAR(*) EXTERNAL F C C....................................................................... C DX=B-A ABSDX=ABS(DX) RELPER=SMALL**0.375 C C....................................................................... C C COMPUTE AN APPROXIMATE BOUND (DFDXB) ON THE PARTIAL C DERIVATIVE OF THE EQUATION WITH RESPECT TO THE C INDEPENDENT VARIABLE. PROTECT AGAINST AN OVERFLOW. C ALSO COMPUTE A BOUND (FBND) ON THE FIRST DERIVATIVE LOCALLY. C DA=SIGN(AMAX1(AMIN1(RELPER*ABS(A),ABSDX),100.*SMALL*ABS(A)),DX) IF (DA .EQ. 0.) DA=RELPER*DX CALL F(A+DA,Y,SF,RPAR,IPAR) DO 10 J=1,NEQ 10 YP(J)=SF(J)-YPRIME(J) DELF=VNORM(YP,NEQ) DFDXB=BIG IF (DELF .LT. BIG*ABS(DA)) DFDXB=DELF/ABS(DA) FBND=VNORM(SF,NEQ) C C....................................................................... C C COMPUTE AN ESTIMATE (DFDUB) OF THE LOCAL LIPSCHITZ CONSTANT FOR C THE SYSTEM OF DIFFERENTIAL EQUATIONS. THIS ALSO REPRESENTS AN C ESTIMATE OF THE NORM OF THE JACOBIAN LOCALLY. C THREE ITERATIONS (TWO WHEN NEQ=1) ARE USED TO ESTIMATE THE C LIPSCHITZ CONSTANT BY NUMERICAL DIFFERENCES. THE FIRST C PERTURBATION VECTOR IS BASED ON THE INITIAL DERIVATIVES AND C DIRECTION OF INTEGRATION. THE SECOND PERTURBATION VECTOR IS C FORMED USING ANOTHER EVALUATION OF THE DIFFERENTIAL EQUATION. C THE THIRD PERTURBATION VECTOR IS FORMED USING PERTURBATIONS BASED C ONLY ON THE INITIAL VALUES. COMPONENTS THAT ARE ZERO ARE ALWAYS C CHANGED TO NON-ZERO VALUES (EXCEPT ON THE FIRST ITERATION). WHEN C INFORMATION IS AVAILABLE, CARE IS TAKEN TO ENSURE THAT COMPONENTS C OF THE PERTURBATION VECTOR HAVE SIGNS WHICH ARE CONSISTENT WITH C THE SLOPES OF LOCAL SOLUTION CURVES. C ALSO CHOOSE THE LARGEST BOUND (FBND) FOR THE FIRST DERIVATIVE. C C PERTURBATION VECTOR SIZE IS HELD CONSTANT FOR C ALL ITERATIONS. COMPUTE THIS CHANGE FROM THE C SIZE OF THE VECTOR OF INITIAL VALUES. DELY=RELPER*VNORM(Y,NEQ) IF (DELY .EQ. 0.) DELY=RELPER DELY=SIGN(DELY,DX) DELF=VNORM(YPRIME,NEQ) FBND=AMAX1(FBND,DELF) IF (DELF .EQ. 0.) GO TO 30 C USE INITIAL DERIVATIVES FOR FIRST PERTURBATION DO 20 J=1,NEQ SPY(J)=YPRIME(J) 20 YP(J)=YPRIME(J) GO TO 50 C CANNOT HAVE A NULL PERTURBATION VECTOR 30 DO 40 J=1,NEQ SPY(J)=0. 40 YP(J)=1. DELF=VNORM(YP,NEQ) C 50 DFDUB=0. LK=MIN0(NEQ+1,3) DO 140 K=1,LK C DEFINE PERTURBED VECTOR OF INITIAL VALUES DO 60 J=1,NEQ 60 PV(J)=Y(J)+DELY*(YP(J)/DELF) IF (K .EQ. 2) GO TO 80 C EVALUATE DERIVATIVES ASSOCIATED WITH PERTURBED C VECTOR AND COMPUTE CORRESPONDING DIFFERENCES CALL F(A,PV,YP,RPAR,IPAR) DO 70 J=1,NEQ 70 PV(J)=YP(J)-YPRIME(J) GO TO 100 C USE A SHIFTED VALUE OF THE INDEPENDENT VARIABLE C IN COMPUTING ONE ESTIMATE 80 CALL F(A+DA,PV,YP,RPAR,IPAR) DO 90 J=1,NEQ 90 PV(J)=YP(J)-SF(J) C CHOOSE LARGEST BOUNDS ON THE FIRST DERIVATIVE C AND A LOCAL LIPSCHITZ CONSTANT 100 FBND=AMAX1(FBND,VNORM(YP,NEQ)) DELF=VNORM(PV,NEQ) IF (DELF .GE. BIG*ABS(DELY)) GO TO 150 DFDUB=AMAX1(DFDUB,DELF/ABS(DELY)) IF (K .EQ. LK) GO TO 160 C CHOOSE NEXT PERTURBATION VECTOR IF (DELF .EQ. 0.) DELF=1. DO 130 J=1,NEQ IF (K .EQ. 2) GO TO 110 DY=ABS(PV(J)) IF (DY .EQ. 0.) DY=DELF GO TO 120 110 DY=Y(J) IF (DY .EQ. 0.) DY=DELY/RELPER 120 IF (SPY(J) .EQ. 0.) SPY(J)=YP(J) IF (SPY(J) .NE. 0.) DY=SIGN(DY,SPY(J)) 130 YP(J)=DY 140 DELF=VNORM(YP,NEQ) C C PROTECT AGAINST AN OVERFLOW 150 DFDUB=BIG C C....................................................................... C C COMPUTE A BOUND (YDPB) ON THE NORM OF THE SECOND DERIVATIVE C 160 YDPB=DFDXB+DFDUB*FBND C C....................................................................... C C DEFINE THE TOLERANCE PARAMETER UPON WHICH THE STARTING STEP SIZE C IS TO BE BASED. A VALUE IN THE MIDDLE OF THE ERROR TOLERANCE C RANGE IS SELECTED. C TOLMIN=BIG TOLSUM=0. DO 170 K=1,NEQ TOLEXP=ALOG10(ETOL(K)) TOLMIN=AMIN1(TOLMIN,TOLEXP) 170 TOLSUM=TOLSUM+TOLEXP TOLP=10.**(0.5*(TOLSUM/FLOAT(NEQ)+TOLMIN)/FLOAT(MORDER+1)) C C....................................................................... C C COMPUTE A STARTING STEP SIZE BASED ON THE ABOVE FIRST AND SECOND C DERIVATIVE INFORMATION C C RESTRICT THE STEP LENGTH TO BE NOT BIGGER THAN C ABS(B-A). (UNLESS B IS TOO CLOSE TO A) H=ABSDX C IF (YDPB .NE. 0. .OR. FBND .NE. 0.) GO TO 180 C C BOTH FIRST DERIVATIVE TERM (FBND) AND SECOND C DERIVATIVE TERM (YDPB) ARE ZERO IF (TOLP .LT. 1.) H=ABSDX*TOLP GO TO 200 C 180 IF (YDPB .NE. 0.) GO TO 190 C C ONLY SECOND DERIVATIVE TERM (YDPB) IS ZERO IF (TOLP .LT. FBND*ABSDX) H=TOLP/FBND GO TO 200 C C SECOND DERIVATIVE TERM (YDPB) IS NON-ZERO 190 SRYDPB=SQRT(0.5*YDPB) IF (TOLP .LT. SRYDPB*ABSDX) H=TOLP/SRYDPB C C FURTHER RESTRICT THE STEP LENGTH TO BE NOT C BIGGER THAN 1/DFDUB 200 IF (H*DFDUB .GT. 1.) H=1./DFDUB C C FINALLY, RESTRICT THE STEP LENGTH TO BE NOT C SMALLER THAN 100*SMALL*ABS(A). HOWEVER, IF C A=0. AND THE COMPUTED H UNDERFLOWED TO ZERO, C THE ALGORITHM RETURNS SMALL*ABS(B) FOR THE C STEP LENGTH. H=AMAX1(H,100.*SMALL*ABS(A)) IF (H .EQ. 0.) H=SMALL*ABS(B) C C NOW SET DIRECTION OF INTEGRATION H=SIGN(H,DX) C RETURN END SUBROUTINE INTYD (T, K, YH, NYH, DKY, IFLAG) C C INTYD APPROXIMATES THE SOLUTION AND DERIVATIVES AT T BY POLYNOMIAL C INTERPOLATION. MUST BE USED IN CONJUNCTION WITH THE INTEGRATOR C PACKAGE SFODE. C----------------------------------------------------------------------- C INTYD COMPUTES INTERPOLATED VALUES OF THE K-TH DERIVATIVE OF THE C DEPENDENT VARIABLE VECTOR Y, AND STORES IT IN DKY. C THIS ROUTINE IS CALLED BY STFODE WITH K = 0,1 AND T = TOUT, BUT MAY C ALSO BE CALLED BY THE USER FOR ANY K UP TO THE CURRENT ORDER. C (SEE DETAILED INSTRUCTIONS IN LSODE USAGE DOCUMENTATION.) C----------------------------------------------------------------------- C THE COMPUTED VALUES IN DKY ARE GOTTEN BY INTERPOLATION USING THE C NORDSIECK HISTORY ARRAY YH. THIS ARRAY CORRESPONDS UNIQUELY TO A C VECTOR-VALUED POLYNOMIAL OF DEGREE NQCUR OR LESS, AND DKY IS SET C TO THE K-TH DERIVATIVE OF THIS POLYNOMIAL AT T. C THE FORMULA FOR DKY IS.. C Q C DKY(I) = SUM C(J,K) * (T - TN)**(J-K) * H**(-J) * YH(I,J+1) C J=K C WHERE C(J,K) = J*(J-1)*...*(J-K+1), Q = NQCUR, TN = TCUR, H = HCUR. C THE QUANTITIES NQ = NQCUR, L = NQ+1, N = NEQ, TN, AND H ARE C COMMUNICATED BY COMMON. THE ABOVE SUM IS DONE IN REVERSE ORDER. C IFLAG IS RETURNED NEGATIVE IF EITHER K OR T IS OUT OF BOUNDS. C----------------------------------------------------------------------- INTEGER K, NYH, IFLAG, I, IC, IER, IOWND, IOWNS, J, JB, JB2, 1 JJ, JJ1, JP1, JSTART, KFLAG, L, MAXORD, METH, MITER, N, NFE, 2 NJE, NQ, NQU, NST REAL T, YH, DKY, 1 ROWND, ROWNS, EL0, H, HMIN, HMXI, HU, TN, UROUND, 2 C, R, S, TP DIMENSION YH(NYH,*), DKY(*) COMMON /DEBDF1/ ROWND, ROWNS(210), 1 EL0, H, HMIN, HMXI, HU, TN, UROUND, IOWND(14), IOWNS(6), 4 IER, JSTART, KFLAG, L, METH, MITER, MAXORD, N, NQ, NST, NFE, 5 NJE, NQU C IFLAG = 0 IF (K .LT. 0 .OR. K .GT. NQ) GO TO 80 TP = TN - HU*(1.0E0 + 100.0E0*UROUND) IF ((T-TP)*(T-TN) .GT. 0.0E0) GO TO 90 C S = (T - TN)/H IC = 1 IF (K .EQ. 0) GO TO 15 JJ1 = L - K DO 10 JJ = JJ1,NQ 10 IC = IC*JJ 15 C = FLOAT(IC) DO 20 I = 1,N 20 DKY(I) = C*YH(I,L) IF (K .EQ. NQ) GO TO 55 JB2 = NQ - K DO 50 JB = 1,JB2 J = NQ - JB JP1 = J + 1 IC = 1 IF (K .EQ. 0) GO TO 35 JJ1 = JP1 - K DO 30 JJ = JJ1,J 30 IC = IC*JJ 35 C = FLOAT(IC) DO 40 I = 1,N 40 DKY(I) = C*YH(I,JP1) + S*DKY(I) 50 CONTINUE IF (K .EQ. 0) RETURN 55 R = H**(-K) DO 60 I = 1,N 60 DKY(I) = R*DKY(I) RETURN C 80 IFLAG = -1 RETURN 90 IFLAG = -2 RETURN C----------------------- END OF SUBROUTINE INTYD ----------------------- END SUBROUTINE STOD (NEQ, Y, YH, NYH, YH1, EWT, SAVF, ACOR, 1 WM, IWM, F, JAC, RPAR, IPAR) C----------------------------------------------------------------------- C STOD PERFORMS ONE STEP OF THE INTEGRATION OF AN INITIAL VALUE C PROBLEM FOR A SYSTEM OF ORDINARY DIFFERENTIAL EQUATIONS. C NOTE.. STOD IS INDEPENDENT OF THE VALUE OF THE ITERATION METHOD C INDICATOR MITER, WHEN THIS IS .NE. 0, AND HENCE IS INDEPENDENT C OF THE TYPE OF CHORD METHOD USED, OR THE JACOBIAN STRUCTURE. C COMMUNICATION WITH STOD IS DONE WITH THE FOLLOWING VARIABLES.. C C Y = AN ARRAY OF LENGTH .GE. N USED AS THE Y ARGUMENT IN C ALL CALLS TO F AND JAC. C NEQ = INTEGER ARRAY CONTAINING PROBLEM SIZE IN NEQ(1), AND C PASSED AS THE NEQ ARGUMENT IN ALL CALLS TO F AND JAC. C YH = AN NYH BY LMAX ARRAY CONTAINING THE DEPENDENT VARIABLES C AND THEIR APPROXIMATE SCALED DERIVATIVES, WHERE C LMAX = MAXORD + 1. YH(I,J+1) CONTAINS THE APPROXIMATE C J-TH DERIVATIVE OF Y(I), SCALED BY H**J/FACTORIAL(J) C (J = 0,1,...,NQ). ON ENTRY FOR THE FIRST STEP, THE FIRST C TWO COLUMNS OF YH MUST BE SET FROM THE INITIAL VALUES. C NYH = A CONSTANT INTEGER .GE. N, THE FIRST DIMENSION OF YH. C YH1 = A ONE-DIMENSIONAL ARRAY OCCUPYING THE SAME SPACE AS YH. C EWT = AN ARRAY OF N ELEMENTS WITH WHICH THE ESTIMATED LOCAL C ERRORS IN YH ARE COMPARED. C SAVF = AN ARRAY OF WORKING STORAGE, OF LENGTH N. C ACOR = A WORK ARRAY OF LENGTH N, USED FOR THE ACCUMULATED C CORRECTIONS. ON A SUCCESSFUL RETURN, ACOR(I) CONTAINS C THE ESTIMATED ONE-STEP LOCAL ERROR IN Y(I). C WM,IWM = REAL AND INTEGER WORK ARRAYS ASSOCIATED WITH MATRIX C OPERATIONS IN CHORD ITERATION (MITER .NE. 0). C PJAC = NAME OF ROUTINE TO EVALUATE AND PREPROCESS JACOBIAN MATRIX C IF A CHORD METHOD IS BEING USED. C SLVS = NAME OF ROUTINE TO SOLVE LINEAR SYSTEM IN CHORD ITERATION. C H = THE STEP SIZE TO BE ATTEMPTED ON THE NEXT STEP. C H IS ALTERED BY THE ERROR CONTROL ALGORITHM DURING THE C PROBLEM. H CAN BE EITHER POSITIVE OR NEGATIVE, BUT ITS C SIGN MUST REMAIN CONSTANT THROUGHOUT THE PROBLEM. C HMIN = THE MINIMUM ABSOLUTE VALUE OF THE STEP SIZE H TO BE USED. C HMXI = INVERSE OF THE MAXIMUM ABSOLUTE VALUE OF H TO BE USED. C HMXI = 0.0 IS ALLOWED AND CORRESPONDS TO AN INFINITE HMAX. C HMIN AND HMXI MAY BE CHANGED AT ANY TIME, BUT WILL NOT C TAKE EFFECT UNTIL THE NEXT CHANGE OF H IS CONSIDERED. C TN = THE INDEPENDENT VARIABLE. TN IS UPDATED ON EACH STEP TAKEN. C JSTART = AN INTEGER USED FOR INPUT ONLY, WITH THE FOLLOWING C VALUES AND MEANINGS.. C 0 PERFORM THE FIRST STEP. C .GT.0 TAKE A NEW STEP CONTINUING FROM THE LAST. C -1 TAKE THE NEXT STEP WITH A NEW VALUE OF H, MAXORD, C N, METH, MITER, AND/OR MATRIX PARAMETERS. C -2 TAKE THE NEXT STEP WITH A NEW VALUE OF H, C BUT WITH OTHER INPUTS UNCHANGED. C ON RETURN, JSTART IS SET TO 1 TO FACILITATE CONTINUATION. C KFLAG = A COMPLETION CODE WITH THE FOLLOWING MEANINGS.. C 0 THE STEP WAS SUCCESFUL. C -1 THE REQUESTED ERROR COULD NOT BE ACHIEVED. C -2 CORRECTOR CONVERGENCE COULD NOT BE ACHIEVED. C A RETURN WITH KFLAG = -1 OR -2 MEANS EITHER C ABS(H) = HMIN OR 10 CONSECUTIVE FAILURES OCCURRED. C ON A RETURN WITH KFLAG NEGATIVE, THE VALUES OF TN AND C THE YH ARRAY ARE AS OF THE BEGINNING OF THE LAST C STEP, AND H IS THE LAST STEP SIZE ATTEMPTED. C MAXORD = THE MAXIMUM ORDER OF INTEGRATION METHOD TO BE ALLOWED. C METH/MITER = THE METHOD FLAGS. SEE DESCRIPTION IN DRIVER. C N = THE NUMBER OF FIRST-ORDER DIFFERENTIAL EQUATIONS. C----------------------------------------------------------------------- C***ROUTINES CALLED CFOD,SLVS,PJAC,VNWRMS C EXTERNAL F, JAC C INTEGER NEQ, NYH, IWM, I, I1, IALTH, IER, IOWND, IREDO, IRET, 1 IPUP, J, JB, JSTART, KFLAG, L, LMAX, M, MAXORD, MEO, METH, 2 MITER, N, NCF, NEWQ, NFE, NJE, NQ, NQNYH, NQU, NST, NSTEPJ REAL Y, YH, YH1, EWT, SAVF, ACOR, WM, 1 ROWND, CONIT, CRATE, EL, ELCO, HOLD, RC, RMAX, TESCO, 2 EL0, H, HMIN, HMXI, HU, TN, UROUND, 3 DCON, DDN, DEL, DELP, DSM, DUP, EXDN, EXSM, EXUP, 4 R, RH, RHDN, RHSM, RHUP, TOLD, VNWRMS DIMENSION Y(*), YH(NYH,*), YH1(*), EWT(*), SAVF(*), 1 ACOR(*), WM(*), IWM(*), RPAR(*), IPAR(*) COMMON /DEBDF1/ ROWND, CONIT, CRATE, EL(13), ELCO(13,12), 1 HOLD, RC, RMAX, TESCO(3,12), 2 EL0, H, HMIN, HMXI, HU, TN, UROUND, IOWND(7), KSTEPS, IOD(6), 3 IALTH, IPUP, LMAX, MEO, NQNYH, NSTEPJ, 4 IER, JSTART, KFLAG, L, METH, MITER, MAXORD, N, NQ, NST, NFE, 5 NJE, NQU C C KFLAG = 0 TOLD = TN NCF = 0 IF (JSTART .GT. 0) GO TO 200 IF (JSTART .EQ. -1) GO TO 100 IF (JSTART .EQ. -2) GO TO 160 C----------------------------------------------------------------------- C ON THE FIRST CALL, THE ORDER IS SET TO 1, AND OTHER VARIABLES ARE C INITIALIZED. RMAX IS THE MAXIMUM RATIO BY WHICH H CAN BE INCREASED C IN A SINGLE STEP. IT IS INITIALLY 1.E4 TO COMPENSATE FOR THE SMALL C INITIAL H, BUT THEN IS NORMALLY EQUAL TO 10. IF A FAILURE C OCCURS (IN CORRECTOR CONVERGENCE OR ERROR TEST), RMAX IS SET AT 2 C FOR THE NEXT INCREASE. C----------------------------------------------------------------------- LMAX = MAXORD + 1 NQ = 1 L = 2 IALTH = 2 RMAX = 10000.0E0 RC = 0.0E0 EL0 = 1.0E0 CRATE = 0.7E0 DELP = 0.0E0 HOLD = H MEO = METH NSTEPJ = 0 IRET = 3 GO TO 140 C----------------------------------------------------------------------- C THE FOLLOWING BLOCK HANDLES PRELIMINARIES NEEDED WHEN JSTART = -1. C IPUP IS SET TO MITER TO FORCE A MATRIX UPDATE. C IF AN ORDER INCREASE IS ABOUT TO BE CONSIDERED (IALTH = 1), C IALTH IS RESET TO 2 TO POSTPONE CONSIDERATION ONE MORE STEP. C IF THE CALLER HAS CHANGED METH, CFOD IS CALLED TO RESET C THE COEFFICIENTS OF THE METHOD. C IF THE CALLER HAS CHANGED MAXORD TO A VALUE LESS THAN THE CURRENT C ORDER NQ, NQ IS REDUCED TO MAXORD, AND A NEW H CHOSEN ACCORDINGLY. C IF H IS TO BE CHANGED, YH MUST BE RESCALED. C IF H OR METH IS BEING CHANGED, IALTH IS RESET TO L = NQ + 1 C TO PREVENT FURTHER CHANGES IN H FOR THAT MANY STEPS. C----------------------------------------------------------------------- 100 IPUP = MITER LMAX = MAXORD + 1 IF (IALTH .EQ. 1) IALTH = 2 IF (METH .EQ. MEO) GO TO 110 CALL CFOD (METH, ELCO, TESCO) MEO = METH IF (NQ .GT. MAXORD) GO TO 120 IALTH = L IRET = 1 GO TO 150 110 IF (NQ .LE. MAXORD) GO TO 160 120 NQ = MAXORD L = LMAX DO 125 I = 1,L 125 EL(I) = ELCO(I,NQ) NQNYH = NQ*NYH RC = RC*EL(1)/EL0 EL0 = EL(1) CONIT = 0.5E0/FLOAT(NQ+2) DDN = VNWRMS (N, SAVF, EWT)/TESCO(1,L) EXDN = 1.0E0/FLOAT(L) RHDN = 1.0E0/(1.3E0*DDN**EXDN + 0.0000013E0) RH = AMIN1(RHDN,1.0E0) IREDO = 3 IF (H .EQ. HOLD) GO TO 170 RH = AMIN1(RH,ABS(H/HOLD)) H = HOLD GO TO 175 C----------------------------------------------------------------------- C CFOD IS CALLED TO GET ALL THE INTEGRATION COEFFICIENTS FOR THE C CURRENT METH. THEN THE EL VECTOR AND RELATED CONSTANTS ARE RESET C WHENEVER THE ORDER NQ IS CHANGED, OR AT THE START OF THE PROBLEM. C----------------------------------------------------------------------- 140 CALL CFOD (METH, ELCO, TESCO) 150 DO 155 I = 1,L 155 EL(I) = ELCO(I,NQ) NQNYH = NQ*NYH RC = RC*EL(1)/EL0 EL0 = EL(1) CONIT = 0.5E0/FLOAT(NQ+2) GO TO (160, 170, 200), IRET C----------------------------------------------------------------------- C IF H IS BEING CHANGED, THE H RATIO RH IS CHECKED AGAINST C RMAX, HMIN, AND HMXI, AND THE YH ARRAY RESCALED. IALTH IS SET TO C L = NQ + 1 TO PREVENT A CHANGE OF H FOR THAT MANY STEPS, UNLESS C FORCED BY A CONVERGENCE OR ERROR TEST FAILURE. C----------------------------------------------------------------------- 160 IF (H .EQ. HOLD) GO TO 200 RH = H/HOLD H = HOLD IREDO = 3 GO TO 175 170 RH = AMAX1(RH,HMIN/ABS(H)) 175 RH = AMIN1(RH,RMAX) RH = RH/AMAX1(1.0E0,ABS(H)*HMXI*RH) R = 1.0E0 DO 180 J = 2,L R = R*RH DO 180 I = 1,N 180 YH(I,J) = YH(I,J)*R H = H*RH RC = RC*RH IALTH = L IF (IREDO .EQ. 0) GO TO 680 C----------------------------------------------------------------------- C THIS SECTION COMPUTES THE PREDICTED VALUES BY EFFECTIVELY C MULTIPLYING THE YH ARRAY BY THE PASCAL TRIANGLE MATRIX. C RC IS THE RATIO OF NEW TO OLD VALUES OF THE COEFFICIENT H*EL(1). C WHEN RC DIFFERS FROM 1 BY MORE THAN 30 PERCENT, IPUP IS SET TO MITER C TO FORCE PJAC TO BE CALLED, IF A JACOBIAN IS INVOLVED. C IN ANY CASE, PJAC IS CALLED AT LEAST EVERY 20-TH STEP. C----------------------------------------------------------------------- 200 IF (ABS(RC-1.0E0) .GT. 0.3E0) IPUP = MITER IF (NST .GE. NSTEPJ+20) IPUP = MITER TN = TN + H I1 = NQNYH + 1 DO 215 JB = 1,NQ I1 = I1 - NYH DO 210 I = I1,NQNYH IPNYH = I + NYH 210 YH1(I) = YH1(I) + YH1(IPNYH) 215 CONTINUE KSTEPS = KSTEPS + 1 C----------------------------------------------------------------------- C UP TO 3 CORRECTOR ITERATIONS ARE TAKEN. A CONVERGENCE TEST IS C MADE ON THE R.M.S. NORM OF EACH CORRECTION, WEIGHTED BY THE ERROR C WEIGHT VECTOR EWT. THE SUM OF THE CORRECTIONS IS ACCUMULATED IN THE C VECTOR ACOR(I). THE YH ARRAY IS NOT ALTERED IN THE CORRECTOR LOOP. C----------------------------------------------------------------------- 220 M = 0 DO 230 I = 1,N 230 Y(I) = YH(I,1) CALL F (TN, Y, SAVF, RPAR, IPAR) NFE = NFE + 1 IF (IPUP .LE. 0) GO TO 250 C----------------------------------------------------------------------- C IF INDICATED, THE MATRIX P = I - H*EL(1)*J IS REEVALUATED AND C PREPROCESSED BEFORE STARTING THE CORRECTOR ITERATION. IPUP IS SET C TO 0 AS AN INDICATOR THAT THIS HAS BEEN DONE. C----------------------------------------------------------------------- IPUP = 0 RC = 1.0E0 NSTEPJ = NST CRATE = 0.7E0 CALL PJAC (NEQ, Y, YH, NYH, EWT, ACOR, SAVF, WM, IWM, F, JAC, 1 RPAR, IPAR) IF (IER .NE. 0) GO TO 430 250 DO 260 I = 1,N 260 ACOR(I) = 0.0E0 270 IF (MITER .NE. 0) GO TO 350 C----------------------------------------------------------------------- C IN THE CASE OF FUNCTIONAL ITERATION, UPDATE Y DIRECTLY FROM C THE RESULT OF THE LAST FUNCTION EVALUATION. C----------------------------------------------------------------------- DO 290 I = 1,N SAVF(I) = H*SAVF(I) - YH(I,2) 290 Y(I) = SAVF(I) - ACOR(I) DEL = VNWRMS (N, Y, EWT) DO 300 I = 1,N Y(I) = YH(I,1) + EL(1)*SAVF(I) 300 ACOR(I) = SAVF(I) GO TO 400 C----------------------------------------------------------------------- C IN THE CASE OF THE CHORD METHOD, COMPUTE THE CORRECTOR ERROR, C AND SOLVE THE LINEAR SYSTEM WITH THAT AS RIGHT-HAND SIDE AND C P AS COEFFICIENT MATRIX. C----------------------------------------------------------------------- 350 DO 360 I = 1,N 360 Y(I) = H*SAVF(I) - (YH(I,2) + ACOR(I)) CALL SLVS (WM, IWM, Y, SAVF) IF (IER .NE. 0) GO TO 410 DEL = VNWRMS (N, Y, EWT) DO 380 I = 1,N ACOR(I) = ACOR(I) + Y(I) 380 Y(I) = YH(I,1) + EL(1)*ACOR(I) C----------------------------------------------------------------------- C TEST FOR CONVERGENCE. IF M.GT.0, AN ESTIMATE OF THE CONVERGENCE C RATE CONSTANT IS STORED IN CRATE, AND THIS IS USED IN THE TEST. C----------------------------------------------------------------------- 400 IF (M .NE. 0) CRATE = AMAX1(0.2E0*CRATE,DEL/DELP) DCON = DEL*AMIN1(1.0E0,1.5E0*CRATE)/(TESCO(2,NQ)*CONIT) IF (DCON .LE. 1.0E0) GO TO 450 M = M + 1 IF (M .EQ. 3) GO TO 410 IF (M .GE. 2 .AND. DEL .GT. 2.0E0*DELP) GO TO 410 DELP = DEL CALL F (TN, Y, SAVF, RPAR, IPAR) NFE = NFE + 1 GO TO 270 C----------------------------------------------------------------------- C THE CORRECTOR ITERATION FAILED TO CONVERGE IN 3 TRIES. C IF MITER .NE. 0 AND THE JACOBIAN IS OUT OF DATE, PJAC IS CALLED FOR C THE NEXT TRY. OTHERWISE THE YH ARRAY IS RETRACTED TO ITS VALUES C BEFORE PREDICTION, AND H IS REDUCED, IF POSSIBLE. IF H CANNOT BE C REDUCED OR 10 FAILURES HAVE OCCURRED, EXIT WITH KFLAG = -2. C----------------------------------------------------------------------- 410 IF (IPUP .EQ. 0) GO TO 430 IPUP = MITER GO TO 220 430 TN = TOLD NCF = NCF + 1 RMAX = 2.0E0 I1 = NQNYH + 1 DO 445 JB = 1,NQ I1 = I1 - NYH DO 440 I = I1,NQNYH IPNYH = I + NYH 440 YH1(I) = YH1(I) - YH1(IPNYH) 445 CONTINUE IF (ABS(H) .LE. HMIN*1.00001E0) GO TO 670 IF (NCF .EQ. 10) GO TO 670 RH = 0.25E0 IPUP = MITER IREDO = 1 GO TO 170 C----------------------------------------------------------------------- C THE CORRECTOR HAS CONVERGED. IPUP IS SET TO -1 IF MITER .NE. 0, C TO SIGNAL THAT THE JACOBIAN INVOLVED MAY NEED UPDATING LATER. C THE LOCAL ERROR TEST IS MADE AND CONTROL PASSES TO STATEMENT 500 C IF IT FAILS. C----------------------------------------------------------------------- 450 IF (MITER .NE. 0) IPUP = -1 IF (M .EQ. 0) DSM = DEL/TESCO(2,NQ) IF (M .GT. 0) DSM = VNWRMS (N, ACOR, EWT)/TESCO(2,NQ) IF (DSM .GT. 1.0E0) GO TO 500 C----------------------------------------------------------------------- C AFTER A SUCCESSFUL STEP, UPDATE THE YH ARRAY. C CONSIDER CHANGING H IF IALTH = 1. OTHERWISE DECREASE IALTH BY 1. C IF IALTH IS THEN 1 AND NQ .LT. MAXORD, THEN ACOR IS SAVED FOR C USE IN A POSSIBLE ORDER INCREASE ON THE NEXT STEP. C IF A CHANGE IN H IS CONSIDERED, AN INCREASE OR DECREASE IN ORDER C BY ONE IS CONSIDERED ALSO. A CHANGE IN H IS MADE ONLY IF IT IS BY A C FACTOR OF AT LEAST 1.1. IF NOT, IALTH IS SET TO 3 TO PREVENT C TESTING FOR THAT MANY STEPS. C----------------------------------------------------------------------- KFLAG = 0 IREDO = 0 NST = NST + 1 HU = H NQU = NQ DO 470 J = 1,L DO 470 I = 1,N 470 YH(I,J) = YH(I,J) + EL(J)*ACOR(I) IALTH = IALTH - 1 IF (IALTH .EQ. 0) GO TO 520 IF (IALTH .GT. 1) GO TO 690 IF (L .EQ. LMAX) GO TO 690 DO 490 I = 1,N 490 YH(I,LMAX) = ACOR(I) GO TO 690 C----------------------------------------------------------------------- C THE ERROR TEST FAILED. KFLAG KEEPS TRACK OF MULTIPLE FAILURES. C RESTORE TN AND THE YH ARRAY TO THEIR PREVIOUS VALUES, AND PREPARE C TO TRY THE STEP AGAIN. COMPUTE THE OPTIMUM STEP SIZE FOR THIS OR C ONE LOWER ORDER. AFTER 2 OR MORE FAILURES, H IS FORCED TO DECREASE C BY A FACTOR OF 0.2 OR LESS. C----------------------------------------------------------------------- 500 KFLAG = KFLAG - 1 TN = TOLD I1 = NQNYH + 1 DO 515 JB = 1,NQ I1 = I1 - NYH DO 510 I = I1,NQNYH IPNYH = I + NYH 510 YH1(I) = YH1(I) - YH1(IPNYH) 515 CONTINUE RMAX = 2.0E0 IF (ABS(H) .LE. HMIN*1.00001E0) GO TO 660 IF (KFLAG .LE. -3) GO TO 640 IREDO = 2 RHUP = 0.0E0 GO TO 540 C----------------------------------------------------------------------- C REGARDLESS OF THE SUCCESS OR FAILURE OF THE STEP, FACTORS C RHDN, RHSM, AND RHUP ARE COMPUTED, BY WHICH H COULD BE MULTIPLIED C AT ORDER NQ - 1, ORDER NQ, OR ORDER NQ + 1, RESPECTIVELY. C IN THE CASE OF FAILURE, RHUP = 0.0 TO AVOID AN ORDER INCREASE. C THE LARGEST OF THESE IS DETERMINED AND THE NEW ORDER CHOSEN C ACCORDINGLY. IF THE ORDER IS TO BE INCREASED, WE COMPUTE ONE C ADDITIONAL SCALED DERIVATIVE. C----------------------------------------------------------------------- 520 RHUP = 0.0E0 IF (L .EQ. LMAX) GO TO 540 DO 530 I = 1,N 530 SAVF(I) = ACOR(I) - YH(I,LMAX) DUP = VNWRMS (N, SAVF, EWT)/TESCO(3,NQ) EXUP = 1.0E0/FLOAT(L+1) RHUP = 1.0E0/(1.4E0*DUP**EXUP + 0.0000014E0) 540 EXSM = 1.0E0/FLOAT(L) RHSM = 1.0E0/(1.2E0*DSM**EXSM + 0.0000012E0) RHDN = 0.0E0 IF (NQ .EQ. 1) GO TO 560 DDN = VNWRMS (N, YH(1,L), EWT)/TESCO(1,NQ) EXDN = 1.0E0/FLOAT(NQ) RHDN = 1.0E0/(1.3E0*DDN**EXDN + 0.0000013E0) 560 IF (RHSM .GE. RHUP) GO TO 570 IF (RHUP .GT. RHDN) GO TO 590 GO TO 580 570 IF (RHSM .LT. RHDN) GO TO 580 NEWQ = NQ RH = RHSM GO TO 620 580 NEWQ = NQ - 1 RH = RHDN IF (KFLAG .LT. 0 .AND. RH .GT. 1.0E0) RH = 1.0E0 GO TO 620 590 NEWQ = L RH = RHUP IF (RH .LT. 1.1E0) GO TO 610 R = EL(L)/FLOAT(L) DO 600 I = 1,N 600 YH(I,NEWQ+1) = ACOR(I)*R GO TO 630 610 IALTH = 3 GO TO 690 620 IF ((KFLAG .EQ. 0) .AND. (RH .LT. 1.1E0)) GO TO 610 IF (KFLAG .LE. -2) RH = AMIN1(RH,0.2E0) C----------------------------------------------------------------------- C IF THERE IS A CHANGE OF ORDER, RESET NQ, L, AND THE COEFFICIENTS. C IN ANY CASE H IS RESET ACCORDING TO RH AND THE YH ARRAY IS RESCALED. C THEN EXIT FROM 680 IF THE STEP WAS OK, OR REDO THE STEP OTHERWISE. C----------------------------------------------------------------------- IF (NEWQ .EQ. NQ) GO TO 170 630 NQ = NEWQ L = NQ + 1 IRET = 2 GO TO 150 C----------------------------------------------------------------------- C CONTROL REACHES THIS SECTION IF 3 OR MORE FAILURES HAVE OCCURED. C IF 10 FAILURES HAVE OCCURRED, EXIT WITH KFLAG = -1. C IT IS ASSUMED THAT THE DERIVATIVES THAT HAVE ACCUMULATED IN THE C YH ARRAY HAVE ERRORS OF THE WRONG ORDER. HENCE THE FIRST C DERIVATIVE IS RECOMPUTED, AND THE ORDER IS SET TO 1. THEN C H IS REDUCED BY A FACTOR OF 10, AND THE STEP IS RETRIED, C UNTIL IT SUCCEEDS OR H REACHES HMIN. C----------------------------------------------------------------------- 640 IF (KFLAG .EQ. -10) GO TO 660 RH = 0.1E0 RH = AMAX1(HMIN/ABS(H),RH) H = H*RH DO 645 I = 1,N 645 Y(I) = YH(I,1) CALL F (TN, Y, SAVF, RPAR, IPAR) NFE = NFE + 1 DO 650 I = 1,N 650 YH(I,2) = H*SAVF(I) IPUP = MITER IALTH = 5 IF (NQ .EQ. 1) GO TO 200 NQ = 1 L = 2 IRET = 3 GO TO 150 C----------------------------------------------------------------------- C ALL RETURNS ARE MADE THROUGH THIS SECTION. H IS SAVED IN HOLD C TO ALLOW THE CALLER TO CHANGE H ON THE NEXT STEP. C----------------------------------------------------------------------- 660 KFLAG = -1 GO TO 700 670 KFLAG = -2 GO TO 700 680 RMAX = 10.0E0 690 R = 1.0E0/TESCO(2,NQU) DO 695 I = 1,N 695 ACOR(I) = ACOR(I)*R 700 HOLD = H JSTART = 1 RETURN C----------------------- END OF SUBROUTINE STOD ----------------------- END SUBROUTINE CFOD (METH, ELCO, TESCO) C C CFOD DEFINES COEFFICIENTS NEEDED IN THE INTEGRATOR PACKAGE SFODE C INTEGER METH, I, IB, NQ, NQM1, NQP1 REAL ELCO, TESCO, AGAMQ, FNQ, FNQM1, PC, PINT, RAGQ, 1 RQFAC, RQ1FAC, TSIGN, XPIN DIMENSION ELCO(13, *), TESCO(3, *) C----------------------------------------------------------------------- C CFOD IS CALLED BY THE INTEGRATOR ROUTINE TO SET COEFFICIENTS C NEEDED THERE. THE COEFFICIENTS FOR THE CURRENT METHOD, AS C GIVEN BY THE VALUE OF METH, ARE SET FOR ALL ORDERS AND SAVED. C THE MAXIMUM ORDER ASSUMED HERE IS 12 IF METH = 1 AND 5 IF METH = 2. C (A SMALLER VALUE OF THE MAXIMUM ORDER IS ALSO ALLOWED.) C CFOD IS CALLED ONCE AT THE BEGINNING OF THE PROBLEM, C AND IS NOT CALLED AGAIN UNLESS AND UNTIL METH IS CHANGED. C C THE ELCO ARRAY CONTAINS THE BASIC METHOD COEFFICIENTS. C THE COEFFICIENTS EL(I), 1 .LE. I .LE. NQ+1, FOR THE METHOD OF C ORDER NQ ARE STORED IN ELCO(I,NQ). THEY ARE GIVEN BY A GENETRATING C POLYNOMIAL, I.E., C L(X) = EL(1) + EL(2)*X + ... + EL(NQ+1)*X**NQ. C FOR THE IMPLICIT ADAMS METHODS, L(X) IS GIVEN BY C DL/DX = (X+1)*(X+2)*...*(X+NQ-1)/FACTORIAL(NQ-1), L(-1) = 0. C FOR THE BDF METHODS, L(X) IS GIVEN BY C L(X) = (X+1)*(X+2)* ... *(X+NQ)/K, C WHERE K = FACTORIAL(NQ)*(1 + 1/2 + ... + 1/NQ). C C THE TESCO ARRAY CONTAINS TEST CONSTANTS USED FOR THE C LOCAL ERROR TEST AND THE SELECTION OF STEP SIZE AND/OR ORDER. C AT ORDER NQ, TESCO(K,NQ) IS USED FOR THE SELECTION OF STEP C SIZE AT ORDER NQ - 1 IF K = 1, AT ORDER NQ IF K = 2, AND AT ORDER C NQ + 1 IF K = 3. C----------------------------------------------------------------------- DIMENSION PC(12) C GO TO (100, 200), METH C 100 ELCO(1,1) = 1.0E0 ELCO(2,1) = 1.0E0 TESCO(1,1) = 0.0E0 TESCO(2,1) = 2.0E0 TESCO(1,2) = 1.0E0 TESCO(3,12) = 0.0E0 PC(1) = 1.0E0 RQFAC = 1.0E0 DO 140 NQ = 2,12 C----------------------------------------------------------------------- C THE PC ARRAY WILL CONTAIN THE COEFFICIENTS OF THE POLYNOMIAL C P(X) = (X+1)*(X+2)*...*(X+NQ-1). C INITIALLY, P(X) = 1. C----------------------------------------------------------------------- RQ1FAC = RQFAC RQFAC = RQFAC/FLOAT(NQ) NQM1 = NQ - 1 FNQM1 = FLOAT(NQM1) NQP1 = NQ + 1 C FORM COEFFICIENTS OF P(X)*(X+NQ-1). ---------------------------------- PC(NQ) = 0.0E0 DO 110 IB = 1,NQM1 I = NQP1 - IB 110 PC(I) = PC(I-1) + FNQM1*PC(I) PC(1) = FNQM1*PC(1) C COMPUTE INTEGRAL, -1 TO 0, OF P(X) AND X*P(X). ----------------------- PINT = PC(1) XPIN = PC(1)/2.0E0 TSIGN = 1.0E0 DO 120 I = 2,NQ TSIGN = -TSIGN PINT = PINT + TSIGN*PC(I)/FLOAT(I) 120 XPIN = XPIN + TSIGN*PC(I)/FLOAT(I+1) C STORE COEFFICIENTS IN ELCO AND TESCO. -------------------------------- ELCO(1,NQ) = PINT*RQ1FAC ELCO(2,NQ) = 1.0E0 DO 130 I = 2,NQ 130 ELCO(I+1,NQ) = RQ1FAC*PC(I)/FLOAT(I) AGAMQ = RQFAC*XPIN RAGQ = 1.0E0/AGAMQ TESCO(2,NQ) = RAGQ IF(NQ.LT.12)TESCO(1,NQP1)=RAGQ*RQFAC/FLOAT(NQP1) TESCO(3,NQM1) = RAGQ 140 CONTINUE RETURN C 200 PC(1) = 1.0E0 RQ1FAC = 1.0E0 DO 230 NQ = 1,5 C----------------------------------------------------------------------- C THE PC ARRAY WILL CONTAIN THE COEFFICIENTS OF THE POLYNOMIAL C P(X) = (X+1)*(X+2)*...*(X+NQ). C INITIALLY, P(X) = 1. C----------------------------------------------------------------------- FNQ = FLOAT(NQ) NQP1 = NQ + 1 C FORM COEFFICIENTS OF P(X)*(X+NQ). ------------------------------------ PC(NQP1) = 0.0E0 DO 210 IB = 1,NQ I = NQ + 2 - IB 210 PC(I) = PC(I-1) + FNQ*PC(I) PC(1) = FNQ*PC(1) C STORE COEFFICIENTS IN ELCO AND TESCO. -------------------------------- DO 220 I = 1,NQP1 220 ELCO(I,NQ) = PC(I)/PC(2) ELCO(2,NQ) = 1.0E0 TESCO(1,NQ) = RQ1FAC TESCO(2,NQ) = FLOAT(NQP1)/ELCO(1,NQ) TESCO(3,NQ) = FLOAT(NQ+2)/ELCO(1,NQ) RQ1FAC = RQ1FAC/FNQ 230 CONTINUE RETURN C----------------------- END OF SUBROUTINE CFOD ----------------------- END SUBROUTINE PJAC (NEQ, Y, YH, NYH, EWT, FTEM, SAVF, WM, IWM, 1 F, JAC, RPAR, IPAR) C C PJAC SETS UP THE ITERATION MATRIX (INVOLVING THE JACOBIAN) FOR THE C INTEGRATION PACKAGE SFODE. C C***ROUTINES CALLED VNWRMS,SGEFA,SGBFA C INTEGER NEQ, NYH, IWM, I, I1, I2, IER, II, IOWND, IOWNS, J, J1, 1 JJ, JSTART, KFLAG, L, LENP, MAXORD, MBA, MBAND, MEB1, MEBAND, 2 METH, MITER, ML, ML3, MU, N, NFE, NJE, NQ, NQU, NST EXTERNAL F, JAC REAL Y, YH, EWT, FTEM, SAVF, WM, 1 ROWND, ROWNS, EL0, H, HMIN, HMXI, HU, TN, UROUND, 2 CON, DI, FAC, HL0, R, R0, SRUR, YI, YJ, YJJ, VNWRMS DIMENSION Y(*), YH(NYH,*), EWT(*), FTEM(*), SAVF(*), 1 WM(*), IWM( *), RPAR(*), IPAR(*) COMMON /DEBDF1/ ROWND, ROWNS(210), 1 EL0, H, HMIN, HMXI, HU, TN, UROUND, IOWND(14), IOWNS(6), 4 IER, JSTART, KFLAG, L, METH, MITER, MAXORD, N, NQ, NST, NFE, 5 NJE, NQU C----------------------------------------------------------------------- C PJAC IS CALLED BY STOD TO COMPUTE AND PROCESS THE MATRIX C P = I - H*EL(1)*J , WHERE J IS AN APPROXIMATION TO THE JACOBIAN. C HERE J IS COMPUTED BY THE USER-SUPPLIED ROUTINE JAC IF C MITER = 1 OR 4, OR BY FINITE DIFFERENCING IF MITER = 2, 3, OR 5. C IF MITER = 3, A DIAGONAL APPROXIMATION TO J IS USED. C J IS STORED IN WM AND REPLACED BY P. IF MITER .NE. 3, P IS THEN C SUBJECTED TO LU DECOMPOSITION IN PREPARATION FOR LATER SOLUTION C OF LINEAR SYSTEMS WITH P AS COEFFICIENT MATRIX. THIS IS DONE C BY SGEFA IF MITER = 1 OR 2, AND BY SGBFA IF MITER = 4 OR 5. C C IN ADDITION TO VARIABLES DESCRIBED PREVIOUSLY, COMMUNICATION C WITH PJAC USES THE FOLLOWING.. C Y = ARRAY CONTAINING PREDICTED VALUES ON ENTRY. C FTEM = WORK ARRAY OF LENGTH N (ACOR IN STOD ). C SAVF = ARRAY CONTAINING F EVALUATED AT PREDICTED Y. C WM = REAL WORK SPACE FOR MATRICES. ON OUTPUT IT CONTAINS THE C INVERSE DIAGONAL MATRIX IF MITER = 3 AND THE LU DECOMPOSITION C OF P IF MITER IS 1, 2 , 4, OR 5. C STORAGE OF MATRIX ELEMENTS STARTS AT WM(3). C WM ALSO CONTAINS THE FOLLOWING MATRIX-RELATED DATA.. C WM(1) = SQRT(UROUND), USED IN NUMERICAL JACOBIAN INCREMENTS. C WM(2) = H*EL0, SAVED FOR LATER USE IF MITER = 3. C IWM = INTEGER WORK SPACE CONTAINING PIVOT INFORMATION, STARTING AT C IWM(21), IF MITER IS 1, 2, 4, OR 5. IWM ALSO CONTAINS THE C BAND PARAMETERS ML = IWM(1) AND MU = IWM(2) IF MITER IS 4 OR 5. C EL0 = EL(1) (INPUT). C IER = OUTPUT ERROR FLAG, = 0 IF NO TROUBLE, .NE. 0 IF C P MATRIX FOUND TO BE SINGULAR. C THIS ROUTINE ALSO USES THE COMMON VARIABLES EL0, H, TN, UROUND, C MITER, N, NFE, AND NJE. C----------------------------------------------------------------------- NJE = NJE + 1 HL0 = H*EL0 GO TO (100, 200, 300, 400, 500), MITER C IF MITER = 1, CALL JAC AND MULTIPLY BY SCALAR. ----------------------- 100 LENP = N*N DO 110 I = 1,LENP 110 WM(I+2) = 0.0E0 CALL JAC (TN, Y, WM(3), N, RPAR, IPAR) CON = -HL0 DO 120 I = 1,LENP 120 WM(I+2) = WM(I+2)*CON GO TO 240 C IF MITER = 2, MAKE N CALLS TO F TO APPROXIMATE J. -------------------- 200 FAC = VNWRMS (N, SAVF, EWT) R0 = 1000.0E0*ABS(H)*UROUND*FLOAT(N)*FAC IF (R0 .EQ. 0.0E0) R0 = 1.0E0 SRUR = WM(1) J1 = 2 DO 230 J = 1,N YJ = Y(J) R = AMAX1(SRUR*ABS(YJ),R0*EWT(J)) Y(J) = Y(J) + R FAC = -HL0/R CALL F (TN, Y, FTEM, RPAR, IPAR) DO 220 I = 1,N 220 WM(I+J1) = (FTEM(I) - SAVF(I))*FAC Y(J) = YJ J1 = J1 + N 230 CONTINUE NFE = NFE + N C ADD IDENTITY MATRIX. ------------------------------------------------- 240 J = 3 DO 250 I = 1,N WM(J) = WM(J) + 1.0E0 250 J = J + (N + 1) C DO LU DECOMPOSITION ON P. -------------------------------------------- CALL SGEFA (WM(3), N, N, IWM(21), IER) RETURN C IF MITER = 3, CONSTRUCT A DIAGONAL APPROXIMATION TO J AND P. --------- 300 WM(2) = HL0 IER = 0 R = EL0*0.1E0 DO 310 I = 1,N 310 Y(I) = Y(I) + R*(H*SAVF(I) - YH(I,2)) CALL F (TN, Y, WM(3), RPAR, IPAR) NFE = NFE + 1 DO 320 I = 1,N R0 = H*SAVF(I) - YH(I,2) DI = 0.1E0*R0 - H*(WM(I+2) - SAVF(I)) WM(I+2) = 1.0E0 IF (ABS(R0) .LT. UROUND*EWT(I)) GO TO 320 IF (ABS(DI) .EQ. 0.0E0) GO TO 330 WM(I+2) = 0.1E0*R0/DI 320 CONTINUE RETURN 330 IER = -1 RETURN C IF MITER = 4, CALL JAC AND MULTIPLY BY SCALAR. ----------------------- 400 ML = IWM(1) MU = IWM(2) ML3 = 3 MBAND = ML + MU + 1 MEBAND = MBAND + ML LENP = MEBAND*N DO 410 I = 1,LENP 410 WM(I+2) = 0.0E0 CALL JAC (TN, Y, WM(ML3), MEBAND, RPAR, IPAR) CON = -HL0 DO 420 I = 1,LENP 420 WM(I+2) = WM(I+2)*CON GO TO 570 C IF MITER = 5, MAKE MBAND CALLS TO F TO APPROXIMATE J. ---------------- 500 ML = IWM(1) MU = IWM(2) MBAND = ML + MU + 1 MBA = MIN0(MBAND,N) MEBAND = MBAND + ML MEB1 = MEBAND - 1 SRUR = WM(1) FAC = VNWRMS (N, SAVF, EWT) R0 = 1000.0E0*ABS(H)*UROUND*FLOAT(N)*FAC IF (R0 .EQ. 0.0E0) R0 = 1.0E0 DO 560 J = 1,MBA DO 530 I = J,N,MBAND YI = Y(I) R = AMAX1(SRUR*ABS(YI),R0*EWT(I)) 530 Y(I) = Y(I) + R CALL F (TN, Y, FTEM, RPAR, IPAR) DO 550 JJ = J,N,MBAND Y(JJ) = YH(JJ,1) YJJ = Y(JJ) R = AMAX1(SRUR*ABS(YJJ),R0*EWT(JJ)) FAC = -HL0/R I1 = MAX0(JJ-MU,1) I2 = MIN0(JJ+ML,N) II = JJ*MEB1 - ML + 2 DO 540 I = I1,I2 540 WM(II+I) = (FTEM(I) - SAVF(I))*FAC 550 CONTINUE 560 CONTINUE NFE = NFE + MBA C ADD IDENTITY MATRIX. ------------------------------------------------- 570 II = MBAND + 2 DO 580 I = 1,N WM(II) = WM(II) + 1.0E0 580 II = II + MEBAND C DO LU DECOMPOSITION OF P. -------------------------------------------- CALL SGBFA (WM(3), MEBAND, N, ML, MU, IWM(21), IER) RETURN C----------------------- END OF SUBROUTINE PJAC ----------------------- END SUBROUTINE SLVS (WM, IWM, X, TEM) C C SLVS SOLVES THE LINEAR SYSTEM IN THE ITERATION SCHEME FOR THE C INTEGRATOR PACKAGE SFODE. C C***ROUTINES CALLED SGESL,SGBSL C INTEGER IWM, I, IER, IOWND, IOWNS, JSTART, KFLAG, L, MAXORD, 1 MEBAND, METH, MITER, ML, MU, N, NFE, NJE, NQ, NQU, NST REAL WM, X, TEM, 1 ROWND, ROWNS, EL0, H, HMIN, HMXI, HU, TN, UROUND, 2 DI, HL0, PHL0, R DIMENSION WM(*), IWM( *), X(*), TEM(*) COMMON /DEBDF1/ ROWND, ROWNS(210), 1 EL0, H, HMIN, HMXI, HU, TN, UROUND, IOWND(14), IOWNS(6), 4 IER, JSTART, KFLAG, L, METH, MITER, MAXORD, N, NQ, NST, NFE, 5 NJE, NQU C----------------------------------------------------------------------- C THIS ROUTINE MANAGES THE SOLUTION OF THE LINEAR SYSTEM ARISING FROM C A CHORD ITERATION. IT IS CALLED BY STOD IF MITER .NE. 0. C IF MITER IS 1 OR 2, IT CALLS SGESL TO ACCOMPLISH THIS. C IF MITER = 3 IT UPDATES THE COEFFICIENT H*EL0 IN THE DIAGONAL C MATRIX, AND THEN COMPUTES THE SOLUTION. C IF MITER IS 4 OR 5, IT CALLS SGBSL. C COMMUNICATION WITH SLVS USES THE FOLLOWING VARIABLES.. C WM = REAL WORK SPACE CONTAINING THE INVERSE DIAGONAL MATRIX IF MITER C IS 3 AND THE LU DECOMPOSITION OF THE MATRIX OTHERWISE. C STORAGE OF MATRIX ELEMENTS STARTS AT WM(3). C WM ALSO CONTAINS THE FOLLOWING MATRIX-RELATED DATA.. C WM(1) = SQRT(UROUND) (NOT USED HERE), C WM(2) = HL0, THE PREVIOUS VALUE OF H*EL0, USED IF MITER = 3. C IWM = INTEGER WORK SPACE CONTAINING PIVOT INFORMATION, STARTING AT C IWM(21), IF MITER IS 1, 2, 4, OR 5. IWM ALSO CONTAINS THE C BAND PARAMETERS ML = IWM(1) AND MU = IWM(2) IF MITER IS 4 OR 5. C X = THE RIGHT-HAND SIDE VECTOR ON INPUT, AND THE SOLUTION VECTOR C ON OUTPUT, OF LENGTH N. C TEM = VECTOR OF WORK SPACE OF LENGTH N, NOT USED IN THIS VERSION. C IER = OUTPUT FLAG (IN COMMON). IER = 0 IF NO TROUBLE OCCURRED. C IER = -1 IF A SINGULAR MATRIX AROSE WITH MITER = 3. C THIS ROUTINE ALSO USES THE COMMON VARIABLES EL0, H, MITER, AND N. C----------------------------------------------------------------------- IER = 0 GO TO (100, 100, 300, 400, 400), MITER 100 CALL SGESL (WM(3), N, N, IWM(21), X, 0) RETURN C 300 PHL0 = WM(2) HL0 = H*EL0 WM(2) = HL0 IF (HL0 .EQ. PHL0) GO TO 330 R = HL0/PHL0 DO 320 I = 1,N DI = 1.0E0 - R*(1.0E0 - 1.0E0/WM(I+2)) IF (ABS(DI) .EQ. 0.0E0) GO TO 390 320 WM(I+2) = 1.0E0/DI 330 DO 340 I = 1,N 340 X(I) = WM(I+2)*X(I) RETURN 390 IER = -1 RETURN C 400 ML = IWM(1) MU = IWM(2) MEBAND = 2*ML + MU + 1 CALL SGBSL (WM(3), MEBAND, N, ML, MU, IWM(21), X, 0) RETURN C----------------------- END OF SUBROUTINE SLVS ----------------------- END SUBROUTINE SGBFA(ABD,LDA,N,ML,MU,IPVT,INFO) INTEGER LDA,N,ML,MU,IPVT(*),INFO REAL ABD(LDA,*) C C SGBFA FACTORS A REAL BAND MATRIX BY ELIMINATION. C C SGBFA IS USUALLY CALLED BY SGBCO, BUT IT CAN BE CALLED C DIRECTLY WITH A SAVING IN TIME IF RCOND IS NOT NEEDED. C C ON ENTRY C C ABD REAL(LDA, N) C CONTAINS THE MATRIX IN BAND STORAGE. THE COLUMNS C OF THE MATRIX ARE STORED IN THE COLUMNS OF ABD AND C THE DIAGONALS OF THE MATRIX ARE STORED IN ROWS C ML+1 THROUGH 2*ML+MU+1 OF ABD . C SEE THE COMMENTS BELOW FOR DETAILS. C C LDA INTEGER C THE LEADING DIMENSION OF THE ARRAY ABD . C LDA MUST BE .GE. 2*ML + MU + 1 . C C N INTEGER C THE ORDER OF THE ORIGINAL MATRIX. C C ML INTEGER C NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL. C 0 .LE. ML .LT. N . C C MU INTEGER C NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL. C 0 .LE. MU .LT. N . C MORE EFFICIENT IF ML .LE. MU . C ON RETURN C C ABD AN UPPER TRIANGULAR MATRIX IN BAND STORAGE AND C THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT. C THE FACTORIZATION CAN BE WRITTEN A = L*U WHERE C L IS A PRODUCT OF PERMUTATION AND UNIT LOWER C TRIANGULAR MATRICES AND U IS UPPER TRIANGULAR. C C IPVT INTEGER(N) C AN INTEGER VECTOR OF PIVOT INDICES. C C INFO INTEGER C = 0 NORMAL VALUE. C = K IF U(K,K) .EQ. 0.0 . THIS IS NOT AN ERROR C CONDITION FOR THIS SUBROUTINE, BUT IT DOES C INDICATE THAT SGBSL WILL DIVIDE BY ZERO IF C CALLED. USE RCOND IN SGBCO FOR A RELIABLE C INDICATION OF SINGULARITY. C C BAND STORAGE C C IF A IS A BAND MATRIX, THE FOLLOWING PROGRAM SEGMENT C WILL SET UP THE INPUT. C C ML = (BAND WIDTH BELOW THE DIAGONAL) C MU = (BAND WIDTH ABOVE THE DIAGONAL) C M = ML + MU + 1 C DO 20 J = 1, N C I1 = MAX0(1, J-MU) C I2 = MIN0(N, J+ML) C DO 10 I = I1, I2 C K = I - J + M C ABD(K,J) = A(I,J) C 10 CONTINUE C 20 CONTINUE C C THIS USES ROWS ML+1 THROUGH 2*ML+MU+1 OF ABD . C IN ADDITION, THE FIRST ML ROWS IN ABD ARE USED FOR C ELEMENTS GENERATED DURING THE TRIANGULARIZATION. C THE TOTAL NUMBER OF ROWS NEEDED IN ABD IS 2*ML+MU+1 . C THE ML+MU BY ML+MU UPPER LEFT TRIANGLE AND THE C ML BY ML LOWER RIGHT TRIANGLE ARE NOT REFERENCED. C C LINPACK. THIS VERSION DATED 08/14/78 . C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. C C SUBROUTINES AND FUNCTIONS C C BLAS SAXPY,SSCAL,ISAMAX C FORTRAN MAX0,MIN0 C REAL T INTEGER I,ISAMAX,I0,J,JU,JZ,J0,J1,K,KP1,L,LM,M,MM,NM1 C M = ML + MU + 1 INFO = 0 C C ZERO INITIAL FILL-IN COLUMNS C J0 = MU + 2 J1 = MIN0(N,M) - 1 IF (J1 .LT. J0) GO TO 30 DO 20 JZ = J0, J1 I0 = M + 1 - JZ DO 10 I = I0, ML ABD(I,JZ) = 0.0E0 10 CONTINUE 20 CONTINUE 30 CONTINUE JZ = J1 JU = 0 C C GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING C NM1 = N - 1 IF (NM1 .LT. 1) GO TO 130 DO 120 K = 1, NM1 KP1 = K + 1 C C ZERO NEXT FILL-IN COLUMN C JZ = JZ + 1 IF (JZ .GT. N) GO TO 50 IF (ML .LT. 1) GO TO 50 DO 40 I = 1, ML ABD(I,JZ) = 0.0E0 40 CONTINUE 50 CONTINUE C C FIND L = PIVOT INDEX C LM = MIN0(ML,N-K) L = ISAMAX(LM+1,ABD(M,K),1) + M - 1 IPVT(K) = L + K - M C C ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED C IF (ABD(L,K) .EQ. 0.0E0) GO TO 100 C C INTERCHANGE IF NECESSARY C IF (L .EQ. M) GO TO 60 T = ABD(L,K) ABD(L,K) = ABD(M,K) ABD(M,K) = T 60 CONTINUE C C COMPUTE MULTIPLIERS C T = -1.0E0/ABD(M,K) CALL SSCAL(LM,T,ABD(M+1,K),1) C C ROW ELIMINATION WITH COLUMN INDEXING C JU = MIN0(MAX0(JU,MU+IPVT(K)),N) MM = M IF (JU .LT. KP1) GO TO 90 DO 80 J = KP1, JU L = L - 1 MM = MM - 1 T = ABD(L,J) IF (L .EQ. MM) GO TO 70 ABD(L,J) = ABD(MM,J) ABD(MM,J) = T 70 CONTINUE CALL SAXPY(LM,T,ABD(M+1,K),1,ABD(MM+1,J),1) 80 CONTINUE 90 CONTINUE GO TO 110 100 CONTINUE INFO = K 110 CONTINUE 120 CONTINUE 130 CONTINUE IPVT(N) = N IF (ABD(M,N) .EQ. 0.0E0) INFO = N RETURN END SUBROUTINE SGBSL(ABD,LDA,N,ML,MU,IPVT,B,JOB) INTEGER LDA,N,ML,MU,IPVT(*),JOB REAL ABD(LDA,*),B(*) C C SGBSL SOLVES THE REAL BAND SYSTEM C A * X = B OR TRANS(A) * X = B C USING THE FACTORS COMPUTED BY SGBCO OR SGBFA. C C ON ENTRY C C ABD REAL(LDA, N) C THE OUTPUT FROM SGBCO OR SGBFA. C C LDA INTEGER C THE LEADING DIMENSION OF THE ARRAY ABD . C C N INTEGER C THE ORDER OF THE ORIGINAL MATRIX. C C ML INTEGER C NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL. C C MU INTEGER C NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL. C C IPVT INTEGER(N) C THE PIVOT VECTOR FROM SGBCO OR SGBFA. C C B REAL(N) C THE RIGHT HAND SIDE VECTOR. C C JOB INTEGER C = 0 TO SOLVE A*X = B , C = NONZERO TO SOLVE TRANS(A)*X = B , WHERE C TRANS(A) IS THE TRANSPOSE. C C ON RETURN C C B THE SOLUTION VECTOR X . C C ERROR CONDITION C C A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A C ZERO ON THE DIAGONAL. TECHNICALLY THIS INDICATES SINGULARITY C BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER C SETTING OF LDA . IT WILL NOT OCCUR IF THE SUBROUTINES ARE C CALLED CORRECTLY AND IF SGBCO HAS SET RCOND .GT. 0.0 C OR SGBFA HAS SET INFO .EQ. 0 . C C TO COMPUTE INVERSE(A) * C WHERE C IS A MATRIX C WITH P COLUMNS C CALL SGBCO(ABD,LDA,N,ML,MU,IPVT,RCOND,Z) C IF (RCOND IS TOO SMALL) GO TO ... C DO 10 J = 1, P C CALL SGBSL(ABD,LDA,N,ML,MU,IPVT,C(1,J),0) C 10 CONTINUE C C LINPACK. THIS VERSION DATED 08/14/78 . C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. C C SUBROUTINES AND FUNCTIONS C C BLAS SAXPY,SDOT C FORTRAN MIN0 C REAL SDOT,T INTEGER K,KB,L,LA,LB,LM,M,NM1 C M = MU + ML + 1 NM1 = N - 1 IF (JOB .NE. 0) GO TO 50 C C JOB = 0 , SOLVE A * X = B C FIRST SOLVE L*Y = B C IF (ML .EQ. 0) GO TO 30 IF (NM1 .LT. 1) GO TO 30 DO 20 K = 1, NM1 LM = MIN0(ML,N-K) L = IPVT(K) T = B(L) IF (L .EQ. K) GO TO 10 B(L) = B(K) B(K) = T 10 CONTINUE CALL SAXPY(LM,T,ABD(M+1,K),1,B(K+1),1) 20 CONTINUE 30 CONTINUE C C NOW SOLVE U*X = Y C DO 40 KB = 1, N K = N + 1 - KB B(K) = B(K)/ABD(M,K) LM = MIN0(K,M) - 1 LA = M - LM LB = K - LM T = -B(K) CALL SAXPY(LM,T,ABD(LA,K),1,B(LB),1) 40 CONTINUE GO TO 100 50 CONTINUE C C JOB = NONZERO, SOLVE TRANS(A) * X = B C FIRST SOLVE TRANS(U)*Y = B C DO 60 K = 1, N LM = MIN0(K,M) - 1 LA = M - LM LB = K - LM T = SDOT(LM,ABD(LA,K),1,B(LB),1) B(K) = (B(K) - T)/ABD(M,K) 60 CONTINUE C C NOW SOLVE TRANS(L)*X = Y C IF (ML .EQ. 0) GO TO 90 IF (NM1 .LT. 1) GO TO 90 DO 80 KB = 1, NM1 K = N - KB LM = MIN0(ML,N-K) B(K) = B(K) + SDOT(LM,ABD(M+1,K),1,B(K+1),1) L = IPVT(K) IF (L .EQ. K) GO TO 70 T = B(L) B(L) = B(K) B(K) = T 70 CONTINUE 80 CONTINUE 90 CONTINUE 100 CONTINUE RETURN END FUNCTION VNORM(V,NCOMP) C C COMPUTE THE MAXIMUM NORM OF THE VECTOR V(*) OF LENGTH NCOMP AND C RETURN THE RESULT AS VNORM C DIMENSION V(NCOMP) C VNORM=0. DO 10 K=1,NCOMP 10 VNORM=AMAX1(VNORM,ABS(V(K))) RETURN END REAL FUNCTION VNWRMS (N, V, W) C----------------------------------------------------------------------- C THIS FUNCTION ROUTINE COMPUTES THE WEIGHTED ROOT-MEAN-SQUARE NORM C OF THE VECTOR OF LENGTH N CONTAINED IN THE ARRAY V, WITH WEIGHTS C CONTAINED IN THE ARRAY W OF LENGTH N.. C VNWRMS = SQRT( (1/N) * SUM( V(I)/W(I) )**2 ) C----------------------------------------------------------------------- INTEGER N, I REAL V, W, SUM DIMENSION V(N), W(N) C SUM = 0.0E0 DO 10 I = 1,N 10 SUM = SUM + (V(I)/W(I))**2 VNWRMS = SQRT(SUM/FLOAT(N)) RETURN C----------------------- END OF FUNCTION VNWRMS ------------------------ END SUBROUTINE RK(N,T,H,A,F) C ****************************************************************** C FOURTH ORDER RUNGE-KUTTA PROCEDURE FOR SOLVING DY=F(T,Y) C ****************************************************************** DIMENSION A(*) EXTERNAL F NP1=N+1 IF (H.EQ.0.0) GO TO 50 C HA=.5*H TA=T+HA M=N+N M1=M+1 C DO 10 K=1,N NK=N+K MK=M+K A(NK)=HA*A(NK) 10 A(MK)=A(K)+A(NK) CALL F(TA,A(M1)) C DO 20 K=1,N NK=N+K MK=M+K A(NK)=A(NK)+H*A(MK) 20 A(MK)=A(K)+HA*A(MK) CALL F(TA,A(M1)) C T=T+H DO 30 K=1,N NK=N+K MK=M+K A(MK)=H*A(MK) A(NK)=A(NK)+A(MK) 30 A(MK)=A(K)+A(MK) CALL F(T,A(M1)) C DO 40 K=1,N NK=N+K MK=M+K A(K)=A(K)+(A(NK)+HA*A(MK))/3.0 40 A(NK)=A(K) CALL F(T,A(NP1)) RETURN C 50 DO 51 K=1,N NK=N+K 51 A(NK)=A(K) CALL F(T,A(NP1)) RETURN END SUBROUTINE RK8(N,T,H,Y,DY,W,F) C ****************************************************************** C EIGHTH ORDER RUNGE-KUTTA PROCEDURE FOR SOLVING DY=F(T,Y) C ****************************************************************** REAL Y(N),DY(N),W(*) REAL A(7),B(8,7),C(7),D(9) EXTERNAL F C ------------------- DATA A(1)/.3333333333333333/, A(2)/.5/, A(3)/.6666666666666666/, 1 A(4)/.1666666666666666/, A(5)/1./, A(6)/.8333333333333333/, 2 A(7)/1./ DATA B(1,1)/1./, B(2,1)/3./ DATA B(1,2)/1./, B(2,2)/0./, B(3,2)/3./ DATA B(1,3)/13./, B(2,3)/-27./, B(3,3)/42./, B(4,3)/8./ DATA B(1,4)/389./, B(2,4)/-54./, B(3,4)/966./, B(4,4)/-824./, 1 B(5,4)/243./ DATA B(1,5)/-231./, B(2,5)/81./, B(3,5)/-1164./, B(4,5)/656./, 1 B(5,5)/-122./, B(6,5)/800./ DATA B(1,6)/-127./, B(2,6)/18./, B(3,6)/-678./, B(4,6)/456./, 1 B(5,6)/-9./, B(6,6)/576./, B(7,6)/4./ DATA B(1,7)/1481./, B(2,7)/-81./, B(3,7)/7104./, 1 B(4,7)/-3376./, B(5,7)/72./, B(6,7)/-5040./, 2 B(7,7)/-60./, B(8,7)/720./ DATA C(1)/12./, C(2)/8./, C(3)/54./, C(4)/4320./, C(5)/20./, 1 C(6)/288./, C(7)/820./ DATA D(1)/41./, D(2)/0./, D(3)/27./, D(4)/272./, D(5)/27./, 1 D(6)/216./, D(7)/0./, D(8)/216./, D(9)/41./ C ------------------- IF (H.EQ.0.) GO TO 40 HA=H*4./27. DO 10 K=1,N 10 W(K)=Y(K)+HA*DY(K) CALL F(T+HA,W(1)) DO 11 K=1,N 11 W(K)=Y(K)+H*(DY(K)/18.+W(K)/6.) CALL F(T+H*2./9.,W(1)) C I=1 DO 22 M=2,8 I=I+N M1=M-1 DO 21 K=1,N SUM=B(1,M1)*DY(K) L=K DO 20 J=2,M SUM=SUM+B(J,M1)*W(L) 20 L=L+N 21 W(L)=Y(K)+SUM*H/C(M1) 22 CALL F(T+A(M1)*H,W(I)) C DO 31 K=1,N SUM=D(1)*DY(K) L=K DO 30 M=2,9 SUM=SUM+D(M)*W(L) 30 L=L+N Y(K)=Y(K)+H*SUM/840. 31 DY(K)=Y(K) T=T+H CALL F(T,DY) RETURN C 40 DO 41 K=1,N 41 DY(K)=Y(K) CALL F(T,DY) RETURN END SUBROUTINE SEPDE (COFX, COFY, G, EDGE, BVAL, IORD, A, B, MP1, * C, D, NP1, U, KU, W, NW, IERR) C ---------------------------------------------------------------------- C SOLUTION OF SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS C ON RECTANGULAR DOMAINS C ---------------------------------------------------------------------- REAL U(KU,NP1), W(NW), DUM(1) INTEGER EDGE(4) EXTERNAL COFX, COFY C -------------- DATA ALPHA/0.0/, BETA/0.0/, GAM/0.0/, DEL/0.0/ C -------------- CALL PDEDGE (EDGE, INDX, INDY, IERR) IF (IERR .NE. 0) RETURN C IF (A .GE. B .OR. C .GE. D) GO TO 300 IF (MP1 .LT. 7) GO TO 320 IF (NP1 .LT. 6) GO TO 330 M = MP1 - 1 N = NP1 - 1 HX = (B - A)/FLOAT(M) HY = (D - C)/FLOAT(N) C C DEFINE THE MAXIMUM AND MINIMUM ROW AND COLUMN C THAT IS NEEDED FOR THE RIGHT-HAND SIDE MATRIX C XMIN = A YMIN = C IMIN = 1 IMAX = MP1 JMIN = 1 JMAX = NP1 JCOL = 0 IF (EDGE(1) .NE. 0) GO TO 10 JMIN = 2 YMIN = C + HY JCOL = MP1 10 IF (EDGE(2) .NE. 0) GO TO 20 IMIN = 2 XMIN = A + HX 20 IF (EDGE(3) .EQ. 0) JMAX = N IF (EDGE(4) .EQ. 0) IMAX = M C C DEFINE THE RIGHT-HAND SIDE MATRIX FOR IORD = 2 C IF (KU .LT. MP1) GO TO 310 IF (IORD .NE. 2) GO TO 40 MN = 0 C YJ = YMIN DO 31 J = JMIN,JMAX XI = XMIN DO 30 I = IMIN,IMAX U(I,J) = G(XI, YJ) 30 XI = XI + HX 31 YJ = YJ + HY GO TO 60 C C DEFINE THE RIGHT-HAND SIDE MATRIX FOR IORD = 4 C 40 IF (IORD .NE. 4) GO TO 340 MN = MP1*NP1 IF (MN .GE. NW) GO TO 100 C YJ = YMIN DO 51 J = JMIN,JMAX XI = XMIN DO 50 I = IMIN,IMAX IJ = I + JCOL W(IJ) = G(XI, YJ) 50 XI = XI + HX YJ = YJ + HY 51 JCOL = JCOL + MP1 C C STORE THE BOUNDARY VALUES OF U C 60 IF (EDGE(1) .NE. 0) GO TO 70 XI = A DO 61 I = 1,MP1 U(I,1) = BVAL(1,XI,C) 61 XI = XI + HX C 70 IF (EDGE(2) .NE. 0) GO TO 80 YJ = C DO 71 J = 1,NP1 U(1,J) = BVAL(2,A,YJ) 71 YJ = YJ + HY C 80 IF (EDGE(3) .NE. 0) GO TO 90 XI = A DO 81 I = 1,MP1 U(I,NP1) = BVAL(3,XI,D) 81 XI = XI + HX C 90 IF (EDGE(4) .NE. 0) GO TO 100 YJ = C DO 91 J = 1,NP1 U(MP1,J) = BVAL(4,B,YJ) 91 YJ = YJ + HY C C STORE THE MIXED BOUNDARY CONDITIONS C 100 IC = MN + 1 IF (EDGE(1) .NE. 1) GO TO 120 MN = MN + MP1 IF (MN .GE. NW) GO TO 120 C XI = A L = IC DO 110 I = 1,MP1 W(L) = BVAL(1,XI,C) XI = XI + HX L = L + 1 110 CONTINUE C 120 IA = MN + 1 IF (EDGE(2) .NE. 1) GO TO 140 MN = MN + NP1 IF (MN .GE. NW) GO TO 140 C YJ = C L = IA DO 130 J = 1,NP1 W(L) = BVAL(2,A,YJ) YJ = YJ + HY L = L + 1 130 CONTINUE C 140 ID = MN + 1 IF (EDGE(3) .NE. 1) GO TO 160 MN = MN + MP1 IF (MN .GE. NW) GO TO 160 C XI = A L = ID DO 150 I = 1,MP1 W(L) = BVAL(3,XI,D) XI = XI + HX L = L + 1 150 CONTINUE C 160 IB = MN + 1 IF (EDGE(4) .NE. 1) GO TO 200 MN = MN + NP1 IF (MN .GE. NW) GO TO 200 C YJ = C L = IB DO 170 J = 1,NP1 W(L) = BVAL(4,B,YJ) YJ = YJ + HY L = L + 1 170 CONTINUE C C CALL THE DIFFERENTIAL EQUATION SOLVER C 200 IF (MN .GE. NW) GO TO 350 IW = MN + 1 W(IW) = NW - MN IF (IORD .EQ. 4) GO TO 210 C CALL SEPELL (0, IORD, A, B, M, INDX, W(IA), ALPHA, W(IB), BETA, * C, D, N, INDY, W(IC), GAM, W(ID), DEL, COFX, COFY, * U, KU, U, KU, W(IW), P, IERR) GO TO 220 C 210 CALL SEPELL (0, IORD, A, B, M, INDX, W(IA), ALPHA, W(IB), BETA, * C, D, N, INDY, W(IC), GAM, W(ID), DEL, COFX, COFY, * W(1),MP1, U, KU, W(IW), P, IERR) C 220 NW = W(IW) + MN IF (IERR .NE. 0) RETURN IF (P .EQ. 0.0) RETURN IERR = -1 W(1) = P RETURN C C ERROR RETURN C 300 IERR = 1 RETURN C 310 IERR = 5 RETURN C 320 IERR = 6 RETURN C 330 IERR = 7 RETURN C 340 IERR = 8 RETURN C 350 DUM(1) = 1.0 CALL SEPELL (0, IORD, A, B, M, INDX, DUM, ALPHA, DUM, BETA, * C, D, N, INDY, DUM, GAM, DUM, DEL, COFX, COFY, * U, KU, U, KU, DUM, P, IERR) NW = DUM(1) + MN RETURN END SUBROUTINE PDEDGE (EDGE, INDX, INDY, IERR) INTEGER EDGE(4) C IF (IABS(EDGE(1)) .GT. 1) GO TO 200 IF (IABS(EDGE(2)) .GT. 1) GO TO 200 IF (IABS(EDGE(3)) .GT. 1) GO TO 200 IF (IABS(EDGE(4)) .GT. 1) GO TO 200 IERR = 0 C C PROCESS EDGES 1 AND 3 C IF (EDGE(1)) 10,20,30 C 10 IF (EDGE(3) .NE. -1) GO TO 210 INDY = 0 GO TO 100 C 20 IF (EDGE(3) .EQ. -1) GO TO 210 INDY = 1 + EDGE(3) GO TO 100 C 30 IF (EDGE(3) .EQ. -1) GO TO 210 INDY = 4 - EDGE(3) C C PROCESS EDGES 2 AND 4 C 100 IF (EDGE(2)) 110,120,130 C 110 IF (EDGE(4) .NE. -1) GO TO 220 INDX = 0 RETURN C 120 IF (EDGE(4) .EQ. -1) GO TO 220 INDX = 1 + EDGE(4) RETURN C 130 IF (EDGE(4) .EQ. -1) GO TO 220 INDX = 4 - EDGE(4) RETURN C C ERROR RETURN C 200 IERR = 2 RETURN 210 IERR = 12 RETURN 220 IERR = 13 RETURN END SUBROUTINE SEPELL (INTL,IORDER,A,B,M,MBDCND,BDA,ALPHA,BDB,BETA,C, 1 D,N,NBDCND,BDC,GAMA,BDD,XNU,COFX,COFY,GRHS,MN, 2 USOL,IDMN,W,PERTRB,IERROR) C C C DIMENSION OF BDA(N+1), BDB(N+1), BDC(M+1), BDD(M+1), C ARGUMENTS USOL(IDMN,N+1), GRHS(MN,N+1), C W (SEE ARGUMENT LIST) C C LATEST REVISION JANUARY 1978 (BY THE AUTHORS) C MODIFIED 1986 BY A.H. MORRIS (NSWC) C C PURPOSE SEPELL SOLVES FOR EITHER THE SECOND-ORDER C FINITE DIFFERENCE APPROXIMATION OR A C FOURTH-ORDER APPROXIMATION TO A SEPARABLE C ELLIPTIC EQUATION C C 2 2 C AF(X)*D U/DX + BF(X)*DU/DX + CF(X)*U + C 2 2 C DF(Y)*D U/DY + EF(Y)*DU/DY + FF(Y)*U C C = G(X,Y) C C ON A RECTANGLE (X GREATER THAN OR EQUAL TO A C AND LESS THAN OR EQUAL TO B, Y GREATER THAN C OR EQUAL TO C AND LESS THAN OR EQUAL TO D). C ANY COMBINATION OF PERIODIC OR MIXED BOUNDARY C CONDITIONS IS ALLOWED. C C PURPOSE THE POSSIBLE BOUNDARY CONDITIONS ARE ... C IN THE X-DIRECTION.. C (0) PERIODIC, U(X+B-A,Y)=U(X,Y) FOR ALL Y,X C (1) U(A,Y), U(B,Y) ARE SPECIFIED FOR ALL Y C (2) U(A,Y), DU(B,Y)/DX+BETA*U(B,Y) ARE C SPECIFIED FOR ALL Y C (3) DU(A,Y)/DX+ALPHA*U(A,Y),DU(B,Y)/DX+ C BETA*U(B,Y) ARE SPECIFIED FOR ALL Y C (4) DU(A,Y)/DX+ALPHA*U(A,Y),U(B,Y) ARE C SPECIFIED FOR ALL Y C C IN THE Y-DIRECTION.. C (0) PERIODIC, U(X,Y+D-C)=U(X,Y) FOR ALL X,Y C (1) U(X,C),U(X,D) ARE SPECIFIED FOR ALL X C (2) U(X,C),DU(X,D)/DY+XNU*U(X,D) ARE SPECIFIED C FOR ALL X C (3) DU(X,C)/DY+GAMA*U(X,C),DU(X,D)/DY+ C XNU*U(X,D) ARE SPECIFIED FOR ALL X C (4) DU(X,C)/DY+GAMA*U(X,C),U(X,D) ARE C SPECIFIED FOR ALL X C C ARGUMENTS C C ON INPUT INTL C = 0 ON INITIAL ENTRY TO SEPELL OR IF ANY OF C THE ARGUMENTS C, D, N, NBDCND, COFY ARE C CHANGED FROM A PREVIOUS CALL C = 1 IF C, D, N, NBDCND, COFY ARE UNCHANGED C FROM THE PREVIOUS CALL. C C IORDER C = 2 IF A SECOND-ORDER APPROXIMATION IS SOUGHT C = 4 IF A FOURTH-ORDER APPROXIMATION IS SOUGHT C C A,B C THE RANGE OF THE X-INDEPENDENT VARIABLE, C I.E., X IS GREATER THAN OR EQUAL TO A AND C LESS THAN OR EQUAL TO B. A MUST BE LESS THAN C B. C C M C THE NUMBER OF PANELS INTO WHICH THE INTERVAL C (A,B) IS SUBDIVIDED. HENCE, THERE WILL BE C M+1 GRID POINTS IN THE X-DIRECTION GIVEN BY C XI=A+(I-1)*DLX FOR I=1,2,...,M+1 WHERE C DLX=(B-A)/M IS THE PANEL WIDTH. M MUST BE C LESS THAN IDMN AND GREATER THAN 5. C C MBDCND C INDICATES THE TYPE OF BOUNDARY CONDITION AT C X=A AND X=B C = 0 IF THE SOLUTION IS PERIODIC IN X, I.E., C U(X+B-A,Y)=U(X,Y) FOR ALL Y,X C = 1 IF THE SOLUTION IS SPECIFIED AT X=A AND C X=B, I.E., U(A,Y) AND U(B,Y) ARE C SPECIFIED FOR ALL Y C = 2 IF THE SOLUTION IS SPECIFIED AT X=A AND C THE BOUNDARY CONDITION IS MIXED AT X=B, C I.E., U(A,Y) AND DU(B,Y)/DX+BETA*U(B,Y) C ARE SPECIFIED FOR ALL Y C = 3 IF THE BOUNDARY CONDITIONS AT X=A AND X=B C ARE MIXED, I.E., DU(A,Y)/DX+ALPHA*U(A,Y) C AND DU(B,Y)/DX+BETA*U(B,Y) ARE SPECIFIED C FOR ALL Y C = 4 IF THE BOUNDARY CONDITION AT X=A IS MIXED C AND THE SOLUTION IS SPECIFIED AT X=B, C I.E., DU(A,Y)/DX+ALPHA*U(A,Y) AND U(B,Y) C ARE SPECIFIED FOR ALL Y C C BDA C A ONE-DIMENSIONAL ARRAY OF LENGTH N+1 THAT C SPECIFIES THE VALUES OF DU(A,Y)/DX+ C ALPHA*U(A,Y) AT X=A. WHEN MBDCND=3 OR 4 C BDA(J) = DU(A,YJ)/DX+ALPHA*U(A,YJ), C J=1,2,...,N+1. C WHEN MBDCND HAS ANY OTHER VALUE, BDA IS A C DUMMY PARAMETER. C C ON INPUT ALPHA C THE SCALAR MULTIPLYING THE SOLUTION IN CASE C OF A MIXED BOUNDARY CONDITION AT X=A (SEE C ARGUMENT BDA). IF MBDCND.NE.3,4 THEN ALPHA C IS A DUMMY PARAMETER. C C BDB C A ONE-DIMENSIONAL ARRAY OF LENGTH N+1 THAT C SPECIFIES THE VALUES OF DU(B,Y)/DX+ C BETA*U(B,Y) AT X=B. WHEN MBDCND=2 OR 3 C BDB(J) = DU(B,YJ)/DX+BETA*U(B,YJ), C J=1,2,...,N+1. C WHEN MBDCND HAS ANY OTHER VALUE, BDB IS A C DUMMY PARAMETER. C C BETA C THE SCALAR MULTIPLYING THE SOLUTION IN CASE C OF A MIXED BOUNDARY CONDITION AT X=B (SEE C ARGUMENT BDB). IF MBDCND.NE.2,3 THEN BETA IS C A DUMMY PARAMETER. C C C,D C THE RANGE OF THE Y-INDEPENDENT VARIABLE, C I.E., Y IS GREATER THAN OR EQUAL TO C AND C LESS THAN OR EQUAL TO D. C MUST BE LESS C THAN D. C C N C THE NUMBER OF PANELS INTO WHICH THE INTERVAL C (C,D) IS SUBDIVIDED. HENCE, THERE WILL BE C N+1 GRID POINTS IN THE Y-DIRECTION GIVEN BY C YJ=C+(J-1)*DLY FOR J=1,2,...,N+1 WHERE C DLY=(D-C)/N IS THE PANEL WIDTH. IN ADDITION, C N MUST BE GREATER THAN 4. C C NBDCND C INDICATES THE TYPES OF BOUNDARY CONDITIONS C AT Y=C AND Y=D C = 0 IF THE SOLUTION IS PERIODIC IN Y, I.E., C U(X,Y+D-C)=U(X,Y) FOR ALL X,Y C = 1 IF THE SOLUTION IS SPECIFIED AT Y=C AND C Y = D, I.E., U(X,C) AND U(X,D) ARE C SPECIFIED FOR ALL X C = 2 IF THE SOLUTION IS SPECIFIED AT Y=C AND C THE BOUNDARY CONDITION IS MIXED AT Y=D, C I.E., U(X,C) AND DU(X,D)/DY+XNU*U(X,D) C ARE SPECIFIED FOR ALL X C = 3 IF THE BOUNDARY CONDITIONS ARE MIXED AT C Y=C AND Y=D, I.E., DU(X,D)/DY+GAMA*U(X,C) C AND DU(X,D)/DY+XNU*U(X,D) ARE SPECIFIED C FOR ALL X C = 4 IF THE BOUNDARY CONDITION IS MIXED AT Y=C C AND THE SOLUTION IS SPECIFIED AT Y=D, C I.E. DU(X,C)/DY+GAMA*U(X,C) AND U(X,D) C ARE SPECIFIED FOR ALL X C C BDC C A ONE-DIMENSIONAL ARRAY OF LENGTH M+1 THAT C SPECIFIES THE VALUE OF DU(X,C)/DY+GAMA*U(X,C) C AT Y=C. WHEN NBDCND=3 OR 4 C BDC(I) = DU(XI,C)/DY + GAMA*U(XI,C), C I=1,2,...,M+1. C WHEN NBDCND HAS ANY OTHER VALUE, BDC IS A C DUMMY PARAMETER. C C GAMA C THE SCALAR MULTIPLYING THE SOLUTION IN CASE C OF A MIXED BOUNDARY CONDITION AT Y=C (SEE C ARGUMENT BDC). IF NBDCND.NE.3,4 THEN GAMA IS C A DUMMY PARAMETER. C C BDD C A ONE-DIMENSIONAL ARRAY OF LENGTH M+1 THAT C SPECIFIES THE VALUE OF DU(X,D)/DY + C XNU*U(X,D) AT Y=C. WHEN NBDCND=2 OR 3 C BDD(I) = DU(XI,D)/DY + XNU*U(XI,D), C I=1,2,...,M+1. C WHEN NBDCND HAS ANY OTHER VALUE, BDD IS A C DUMMY PARAMETER. C C XNU C THE SCALAR MULTIPLYING THE SOLUTION IN CASE C OF A MIXED BOUNDARY CONDITION AT Y=D (SEE C ARGUMENT BDD). IF NBDCND.NE.2 OR 3 THEN XNU C IS A DUMMY PARAMETER. C C COFX C A USER-SUPPLIED SUBPROGRAM WITH C PARAMETERS X, AFUN, BFUN, CFUN WHICH C RETURNS THE VALUES OF THE X-DEPENDENT C COEFFICIENTS AF(X), BF(X), CF(X) IN C THE ELLIPTIC EQUATION AT X. C C COFY C A USER-SUPPLIED SUBPROGRAM WITH C PARAMETERS Y, DFUN, EFUN, FFUN WHICH C RETURNS THE VALUES OF THE Y-DEPENDENT C COEFFICIENTS DF(Y), EF(Y), FF(Y) IN C THE ELLIPTIC EQUATION AT Y. C C NOTE. COFX AND COFY MUST BE DECLARED EXTERNAL C IN THE CALLING ROUTINE. THE VALUES RETURNED IN C AFUN AND DFUN MUST SATISFY AFUN*DFUN GREATER C THAN 0 FOR A LESS THAN X LESS THAN B, C C LESS THAN Y LESS THAN D (SEE IERROR=10). C THE COEFFICIENTS PROVIDED MAY LEAD TO A MATRIX C EQUATION WHICH IS NOT DIAGONALLY DOMINANT IN C WHICH CASE SOLUTION MAY FAIL (SEE IERROR=4). C C GRHS C A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE C VALUES OF THE RIGHT-HAND SIDE OF THE ELLIPTIC C EQUATION, I.E., GRHS(I,J)=G(XI,YI), FOR C I=2,...,M, J=2,...,N. AT THE BOUNDARIES, C GRHS IS DEFINED BY C C MBDCND GRHS(1,J) GRHS(M+1,J) C ------ --------- ----------- C 0 G(A,YJ) G(B,YJ) C 1 * * C 2 * G(B,YJ) J=1,2,...,N+1 C 3 G(A,YJ) G(B,YJ) C 4 G(A,YJ) * C C NBDCND GRHS(I,1) GRHS(I,N+1) C ------ --------- ----------- C 0 G(XI,C) G(XI,D) C 1 * * C 2 * G(XI,D) I=1,2,...,M+1 C 3 G(XI,C) G(XI,D) C 4 G(XI,C) * C C WHERE * MEANS THESE QUANTITES ARE NOT USED. C GRHS SHOULD BE DIMENSIONED MN BY AT LEAST C N+1 IN THE CALLING ROUTINE. C C MN C THE ROW (OR FIRST) DIMENSION OF THE ARRAY C GRHS AS IT APPEARS IN THE PROGRAM CALLING C SEPELL. MN MUST BE AT LEAST 7 AND GREATER C THAN OR EQUAL TO M+1. C C USOL C A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE C VALUES OF THE SOLUTION ALONG THE BOUNDARIES. C AT THE BOUNDARIES, USOL IS DEFINED BY C C MBDCND USOL(1,J) USOL(M+1,J) C ------ --------- ----------- C 0 * * C 1 U(A,YJ) U(B,YJ) C 2 U(A,YJ) * J=1,2,...,N+1 C 3 * * C 4 * U(B,YJ) C C NBDCND USOL(I,1) USOL(I,N+1) C ------ --------- ----------- C 0 * * C 1 U(XI,C) U(XI,D) C 2 U(XI,C) * I=1,2,...,M+1 C 3 * * C 4 * U(XI,D) C C WHERE * MEANS THE QUANTITES ARE NOT USED IN C THE SOLUTION. C C IF IORDER=2 AND IDMN=MN, THEN THE USER MAY C EQUIVALENCE GRHS AND USOL. NOTE THAT IN THIS C CASE THE TABLES SPECIFYING THE BOUNDARIES OF C THE GRHS AND USOL ARRAYS DETERMINE THE C BOUNDARIES UNIQUELY EXCEPT AT THE CORNERS. C IF THE TABLES CALL FOR BOTH G(X,Y) AND C U(X,Y) AT A CORNER THEN THE SOLUTION MUST BE C CHOSEN. FOR EXAMPLE, IF MBDCND=2 AND C NBDCND=4, THEN U(A,C), U(A,D), U(B,D) MUST BE C CHOSEN AT THE CORNERS IN ADDITION TO G(B,C). C C IF IORDER=4, THEN THE TWO ARRAYS, USOL AND C GRHS, MUST BE DISTINCT. C C USOL SHOULD BE DIMENSIONED IDMN BY AT LEAST C N+1 IN THE CALLING ROUTINE. C C IDMN C THE ROW (OR FIRST) DIMENSION OF THE ARRAY C USOL AS IT APPEARS IN THE PROGRAM CALLING C SEPELL. IDMN MUST BE AT LEAST 7 AND GREATER C THAN OR EQUAL TO M+1. C C W C A ONE-DIMENSIONAL ARRAY THAT MUST BE PROVIDED C BY THE USER FOR WORK SPACE. LET C K=INT(LOG2(N+1))+1 AND SET L=2**(K+1). C THEN (K-2)*L+K+10*N+12*M+27 WILL SUFFICE C AS A LENGTH OF W. THE ACTUAL LENGTH OF W IN C THE CALLING ROUTINE MUST BE SET IN W(1) (SEE C IERROR=11). C C ON OUTPUT USOL C CONTAINS THE APPROXIMATE SOLUTION TO THE C ELLIPTIC EQUATION. USOL(I,J) IS THE C APPROXIMATION TO U(XI,YJ) FOR I=1,2...,M+1 C AND J=1,2,...,N+1. THE APPROXIMATION HAS C ERROR O(DLX**2+DLY**2) IF CALLED WITH C IORDER=2 AND O(DLX**4+DLY**4) IF CALLED WITH C IORDER=4. C C W C CONTAINS INTERMEDIATE VALUES THAT MUST NOT BE C DESTROYED IF SEPELL IS CALLED AGAIN WITH C INTL=1. IN ADDITION W(1) CONTAINS THE EXACT C MINIMAL LENGTH (IN FLOATING POINT) REQUIRED C FOR THE WORK SPACE (SEE IERROR=11). C C PERTRB C IF A COMBINATION OF PERIODIC OR DERIVATIVE C BOUNDARY CONDITIONS (I.E., ALPHA=BETA=0 IF C MBDCND=3, GAMA=XNU=0 IF NBDCND=3) IS C SPECIFIED AND IF THE COEFFICIENTS OF U(X,Y) C IN THE SEPARABLE ELLIPTIC EQUATION ARE ZERO C (I.E., CF(X)=0 FOR X GREATER THAN OR EQUAL TO C A AND LESS THAN OR EQUAL TO B, FF(Y)=0 FOR C Y GREATER THAN OR EQUAL TO C AND LESS THAN C OR EQUAL TO D) THEN A SOLUTION MAY NOT EXIST. C PERTRB IS A CONSTANT CALCULATED AND C SUBTRACTED FROM THE RIGHT-HAND SIDE OF THE C MATRIX EQUATIONS GENERATED BY SEPELL WHICH C INSURES THAT A SOLUTION EXISTS. SEPELL THEN C COMPUTES THIS SOLUTION WHICH IS A WEIGHTED C MINIMAL LEAST SQUARES SOLUTION TO THE C ORIGINAL PROBLEM. C C IERROR C AN ERROR FLAG THAT INDICATES INVALID INPUT C PARAMETERS OR FAILURE TO FIND A SOLUTION C = 0 NO ERROR C = 1 IF A GREATER THAN B OR C GREATER THAN D C = 2 IF MBDCND LESS THAN 0 OR MBDCND GREATER C THAN 4 C = 3 IF NBDCND LESS THAN 0 OR NBDCND GREATER C THAN 4 C = 4 IF ATTEMPT TO FIND A SOLUTION FAILS. C (THE LINEAR SYSTEM GENERATED IS NOT C DIAGONALLY DOMINANT.) C = 5 IF IDMN OR MN IS TOO SMALL. C = 6 IF M IS TOO SMALL OR TOO LARGE (SEE C DISCUSSION OF M) C = 7 IF N IS TOO SMALL (SEE DISCUSSION OF N) C = 8 IF IORDER IS NOT 2 OR 4 C = 9 IF INTL IS NOT 0 OR 1 C = 10 IF AFUN*DFUN LESS THAN OR EQUAL TO 0 FOR C SOME INTERIOR MESH POINT (XI,YJ) C = 11 IF THE WORK SPACE LENGTH INPUT IN W(1) C IS LESS THAN THE EXACT MINIMAL WORK C SPACE LENGTH REQUIRED OUTPUT IN W(1). C C NOTE (CONCERNING IERROR=4). FOR THE C COEFFICIENTS INPUT THROUGH COFX, COFY, THE C DISCRETIZATION MAY LEAD TO A BLOCK C TRIDIAGONAL LINEAR SYSTEM WHICH IS NOT C DIAGONALLY DOMINANT (FOR EXAMPLE, THIS C HAPPENS IF CFUN=0 AND BFUN/(2.*DLX) GREATER C THAN AFUN/DLX**2). IN THIS CASE SOLUTION MAY C FAIL. THIS CANNOT HAPPEN IN THE LIMIT AS C DLX, DLY APPROACH ZERO. HENCE, THE CONDITION C MAY BE REMEDIED BY TAKING LARGER VALUES FOR M C OR N. C C ENTRY POINTS SEPELL, SEPEL1, CHKPRM, CHKSNG, ORTHG, MINSOL, C TRISP, DEFER, DXFN, DYFN, BLKTRI, BLKTR1,INDXB, C INDXA, INDXC, PROD0, PRODP, CPROD0, CPRODP, C PPADD, PSGF, BSRH, PPSGF, PPSPF, COMPB, C TQLRT0, SPMPAR C C SPECIAL CONDITIONS NONE C C COMMON BLOCKS SPLP, CBLKT C C I/O NONE C C PRECISION SINGLE C C SPECIALIST JOHN C. ADAMS, NCAR, BOULDER, COLORADO 80307 C C HISTORY DEVELOPED AT NCAR DURING 1975-76. C C ALGORITHM SEPELL AUTOMATICALLY DISCRETIZES THE SEPARABLE C ELLIPTIC EQUATION WHICH IS THEN SOLVED BY A C GENERALIZED CYCLIC REDUCTION ALGORITHM IN THE C SUBROUTINE, BLKTRI. THE FOURTH-ORDER SOLUTION C IS OBTAINED USING DEFERRED CORRECTIONS, WHICH C IS DESCRIBED AND REFERENCED IN SECTIONS, C REFERENCES AND METHOD. C C ACCURACY AND TIMING THE FOLLOWING COMPUTATIONAL RESULTS WERE C OBTAINED BY SOLVING THE SAMPLE PROBLEM AT THE C END OF THIS WRITE-UP ON THE CONTROL DATA 7600. C THE OP COUNT IS PROPORTIONAL TO M*N*LOG2(N). C IN CONTRAST TO THE OTHER ROUTINES IN THIS C CHAPTER, ACCURACY IS TESTED BY COMPUTING AND C TABULATING SECOND- AND FOURTH-ORDER C DISCRETIZATION ERRORS. BELOW IS A TABLE C CONTAINING COMPUTATIONAL RESULTS. THE TIMES C GIVEN DO NOT INCLUDE INITIALIZATION (I.E., C TIMES ARE FOR INTL=1). NOTE THAT THE C FOURTH-ORDER ACCURACY IS NOT REALIZED UNTIL THE C MESH IS SUFFICIENTLY REFINED. C C SECOND-ORDER FOURTH-ORDER SECOND-ORDER FOURTH-ORDER C M N EXECUTION TIME EXECUTION TIME ERROR ERROR C (M SEC) (M SEC) C 6 6 6 14 6.8E-1 1.2E0 C 14 14 23 58 1.4E-1 1.8E-1 C 30 30 100 247 3.2E-2 9.7E-3 C 62 62 445 1,091 7.5E-3 3.0E-4 C 126 126 2,002 4,772 1.8E-3 3.5E-6 C C PORTABILITY THE VALUE GIVEN BY SPMPAR(1) IS THE ONLY C MACHINE DEPENDENT CONSTANT THAT IS USED. C C REFERENCES KELLER, H.B., NUMERICAL METHODS FOR TWO-POINT C BOUNDARY-VALUE PROBLEMS, BLAISDEL (1968), C WALTHAM, MASS. C C SWARZTRAUBER, P., AND R. SWEET (1975), C EFFICIENT FORTRAN SUBPROGRAMS FOR THE C SOLUTION OF ELLIPTIC PARTIAL DIFFERENTIAL C EQUATIONS. NCAR TECHNICAL NOTE C NCAR-TN/IA-109, PP. 135-137. C C C REAL GRHS(MN,*), USOL(IDMN,*) REAL BDA(*), BDB(*), BDC(*), BDD(*), W(*) EXTERNAL COFX, COFY C C C CHECK INPUT PARAMETERS C CALL CHKPRM (INTL,IORDER,A,B,M,MBDCND,C,D,N,NBDCND,COFX,COFY, 1 IDMN,MN,IERROR) IF (IERROR .NE. 0) RETURN C C COMPUTE MINIMUM WORK SPACE AND CHECK WORK SPACE LENGTH INPUT C L = N+1 IF (NBDCND .EQ. 0) L = N LOGB2N = INT(ALOG(FLOAT(L)+0.5)/ALOG(2.0))+1 LL = 2**(LOGB2N+1) K = M+1 L = N+1 LENGTH = (LOGB2N-2)*LL+LOGB2N+MAX0(2*L,6*K)+5 IF (NBDCND .EQ. 0) LENGTH = LENGTH+2*L IERROR = 11 LINPUT = INT(W(1)+0.5) LOUTPT = LENGTH+6*(K+L)+1 W(1) = FLOAT(LOUTPT) IF (LOUTPT .GT. LINPUT) RETURN IERROR = 0 C C SET WORK SPACE INDICES C I1 = LENGTH+2 I2 = I1+L I3 = I2+L I4 = I3+L I5 = I4+L I6 = I5+L I7 = I6+L I8 = I7+K I9 = I8+K I10 = I9+K I11 = I10+K I12 = I11+K I13 = 2 CALL SEPEL1 (INTL,IORDER,A,B,M,MBDCND,BDA,ALPHA,BDB,BETA,C,D,N, 1 NBDCND,BDC,GAMA,BDD,XNU,COFX,COFY,W(I1),W(I2),W(I3), 2 W(I4),W(I5),W(I6),W(I7),W(I8),W(I9),W(I10),W(I11), 3 W(I12),GRHS,MN,USOL,IDMN,W(I13),PERTRB,IERROR) RETURN END SUBROUTINE SEPEL1 (INTL,IORDER,A,B,M,MBDCND,BDA,ALPHA,BDB,BETA,C, 1 D,N,NBDCND,BDC,GAMA,BDD,XNU,COFX,COFY,AN,BN, 2 CN,DN,UN,ZN,AM,BM,CM,DM,UM,ZM,GRHS,MN,USOL, 3 IDMN,W,PERTRB,IERROR) C C SEPEL1 SETS UP VECTORS AND ARRAYS FOR INPUT TO BLKTRI C AND COMPUTES A SECOND ORDER SOLUTION IN USOL. A RETURN JUMP TO C SEPELL OCCURRS IF IORDER=2. IF IORDER=4 A FOURTH ORDER C SOLUTION IS GENERATED IN USOL. C DIMENSION BDA(*) ,BDB(*) ,BDC(*) ,BDD(*) , 1 W(*) DIMENSION GRHS(MN,*) ,USOL(IDMN,*) DIMENSION AN(*) ,BN(*) ,CN(*) ,DN(*) , 1 UN(*) ,ZN(*) DIMENSION AM(*) ,BM(*) ,CM(*) ,DM(*) , 1 UM(*) ,ZM(*) LOGICAL SINGLR EXTERNAL COFX, COFY COMMON /SPLP/ KSWX ,KSWY ,K ,L , 1 AIT ,BIT ,CIT ,DIT , 2 MIT ,NIT ,IS ,MS , 3 JS ,NS ,DLX ,DLY , 4 TDLX3 ,TDLY3 ,DLX4 ,DLY4 C C C SET PARAMETERS INTERNALLY C KSWX = MBDCND+1 KSWY = NBDCND+1 K = M+1 L = N+1 AIT = A BIT = B CIT = C DIT = D C C SET RIGHT HAND SIDE VALUES FROM GRHS IN USOL ON THE INTERIOR C AND NON-SPECIFIED BOUNDARIES. C DO 20 I=2,M DO 10 J=2,N USOL(I,J) = GRHS(I,J) 10 CONTINUE 20 CONTINUE IF (KSWX.EQ.2 .OR. KSWX.EQ.3) GO TO 40 DO 30 J=2,N USOL(1,J) = GRHS(1,J) 30 CONTINUE 40 CONTINUE IF (KSWX.EQ.2 .OR. KSWX.EQ.5) GO TO 60 DO 50 J=2,N USOL(K,J) = GRHS(K,J) 50 CONTINUE 60 CONTINUE IF (KSWY.EQ.2 .OR. KSWY.EQ.3) GO TO 80 DO 70 I=2,M USOL(I,1) = GRHS(I,1) 70 CONTINUE 80 CONTINUE IF (KSWY.EQ.2 .OR. KSWY.EQ.5) GO TO 100 DO 90 I=2,M USOL(I,L) = GRHS(I,L) 90 CONTINUE 100 CONTINUE IF (KSWX.NE.2 .AND. KSWX.NE.3 .AND. KSWY.NE.2 .AND. KSWY.NE.3) 1 USOL(1,1) = GRHS(1,1) IF (KSWX.NE.2 .AND. KSWX.NE.5 .AND. KSWY.NE.2 .AND. KSWY.NE.3) 1 USOL(K,1) = GRHS(K,1) IF (KSWX.NE.2 .AND. KSWX.NE.3 .AND. KSWY.NE.2 .AND. KSWY.NE.5) 1 USOL(1,L) = GRHS(1,L) IF (KSWX.NE.2 .AND. KSWX.NE.5 .AND. KSWY.NE.2 .AND. KSWY.NE.5) 1 USOL(K,L) = GRHS(K,L) I1 = 1 C C SET SWITCHES FOR PERIODIC OR NON-PERIODIC BOUNDARIES C MP = 1 NP = 1 IF (KSWX .EQ. 1) MP = 0 IF (KSWY .EQ. 1) NP = 0 C C SET DLX,DLY AND SIZE OF BLOCK TRI-DIAGONAL SYSTEM GENERATED C IN NINT,MINT C DLX = (BIT-AIT)/FLOAT(M) MIT = K-1 IF (KSWX .EQ. 2) MIT = K-2 IF (KSWX .EQ. 4) MIT = K DLY = (DIT-CIT)/FLOAT(N) NIT = L-1 IF (KSWY .EQ. 2) NIT = L-2 IF (KSWY .EQ. 4) NIT = L TDLX3 = 2.0*DLX**3 DLX4 = DLX**4 TDLY3 = 2.0*DLY**3 DLY4 = DLY**4 C C SET SUBSCRIPT LIMITS FOR PORTION OF ARRAY TO INPUT TO BLKTRI C IS = 1 JS = 1 IF (KSWX.EQ.2 .OR. KSWX.EQ.3) IS = 2 IF (KSWY.EQ.2 .OR. KSWY.EQ.3) JS = 2 NS = NIT+JS-1 MS = MIT+IS-1 C C SET X - DIRECTION C DO 110 I=1,MIT XI = AIT+FLOAT(IS+I-2)*DLX CALL COFX (XI,AI,BI,CI) AXI = (AI/DLX-0.5*BI)/DLX BXI = -2.*AI/DLX**2+CI CXI = (AI/DLX+0.5*BI)/DLX AM(I) = AXI BM(I) = BXI CM(I) = CXI 110 CONTINUE C C SET Y DIRECTION C DO 120 J=1,NIT YJ = CIT+FLOAT(JS+J-2)*DLY CALL COFY (YJ,DJ,EJ,FJ) DYJ = (DJ/DLY-0.5*EJ)/DLY EYJ = (-2.*DJ/DLY**2+FJ) FYJ = (DJ/DLY+0.5*EJ)/DLY AN(J) = DYJ BN(J) = EYJ CN(J) = FYJ 120 CONTINUE C C ADJUST EDGES IN X DIRECTION UNLESS PERIODIC C AX1 = AM(1) CXM = CM(MIT) GO TO (170,130,150,160,140),KSWX C C DIRICHLET-DIRICHLET IN X DIRECTION C 130 AM(1) = 0.0 CM(MIT) = 0.0 GO TO 170 C C MIXED-DIRICHLET IN X DIRECTION C 140 AM(1) = 0.0 BM(1) = BM(1)+2.*ALPHA*DLX*AX1 CM(1) = CM(1)+AX1 CM(MIT) = 0.0 GO TO 170 C C DIRICHLET-MIXED IN X DIRECTION C 150 AM(1) = 0.0 AM(MIT) = AM(MIT)+CXM BM(MIT) = BM(MIT)-2.*BETA*DLX*CXM CM(MIT) = 0.0 GO TO 170 C C MIXED - MIXED IN X DIRECTION C 160 CONTINUE AM(1) = 0.0 BM(1) = BM(1)+2.*DLX*ALPHA*AX1 CM(1) = CM(1)+AX1 AM(MIT) = AM(MIT)+CXM BM(MIT) = BM(MIT)-2.*DLX*BETA*CXM CM(MIT) = 0.0 170 CONTINUE C C ADJUST IN Y DIRECTION UNLESS PERIODIC C DY1 = AN(1) FYN = CN(NIT) GO TO (220,180,200,210,190),KSWY C C DIRICHLET-DIRICHLET IN Y DIRECTION C 180 CONTINUE AN(1) = 0.0 CN(NIT) = 0.0 GO TO 220 C C MIXED-DIRICHLET IN Y DIRECTION C 190 CONTINUE AN(1) = 0.0 BN(1) = BN(1)+2.*DLY*GAMA*DY1 CN(1) = CN(1)+DY1 CN(NIT) = 0.0 GO TO 220 C C DIRICHLET-MIXED IN Y DIRECTION C 200 AN(1) = 0.0 AN(NIT) = AN(NIT)+FYN BN(NIT) = BN(NIT)-2.*DLY*XNU*FYN CN(NIT) = 0.0 GO TO 220 C C MIXED - MIXED DIRECTION IN Y DIRECTION C 210 CONTINUE AN(1) = 0.0 BN(1) = BN(1)+2.*DLY*GAMA*DY1 CN(1) = CN(1)+DY1 AN(NIT) = AN(NIT)+FYN BN(NIT) = BN(NIT)-2.0*DLY*XNU*FYN CN(NIT) = 0.0 220 IF (KSWX .EQ. 1) GO TO 270 C C ADJUST USOL ALONG X EDGE C DO 260 J=JS,NS IF (KSWX.NE.2 .AND. KSWX.NE.3) GO TO 230 USOL(IS,J) = USOL(IS,J)-AX1*USOL(1,J) GO TO 240 230 USOL(IS,J) = USOL(IS,J)+2.0*DLX*AX1*BDA(J) 240 IF (KSWX.NE.2 .AND. KSWX.NE.5) GO TO 250 USOL(MS,J) = USOL(MS,J)-CXM*USOL(K,J) GO TO 260 250 USOL(MS,J) = USOL(MS,J)-2.0*DLX*CXM*BDB(J) 260 CONTINUE 270 IF (KSWY .EQ. 1) GO TO 320 C C ADJUST USOL ALONG Y EDGE C DO 310 I=IS,MS IF (KSWY.NE.2 .AND. KSWY.NE.3) GO TO 280 USOL(I,JS) = USOL(I,JS)-DY1*USOL(I,1) GO TO 290 280 USOL(I,JS) = USOL(I,JS)+2.0*DLY*DY1*BDC(I) 290 IF (KSWY.NE.2 .AND. KSWY.NE.5) GO TO 300 USOL(I,NS) = USOL(I,NS)-FYN*USOL(I,L) GO TO 310 300 USOL(I,NS) = USOL(I,NS)-2.0*DLY*FYN*BDD(I) 310 CONTINUE 320 CONTINUE C C SAVE ADJUSTED EDGES IN GRHS IF IORDER=4 C IF (IORDER .NE. 4) GO TO 350 DO 330 J=JS,NS GRHS(IS,J) = USOL(IS,J) GRHS(MS,J) = USOL(MS,J) 330 CONTINUE DO 340 I=IS,MS GRHS(I,JS) = USOL(I,JS) GRHS(I,NS) = USOL(I,NS) 340 CONTINUE 350 CONTINUE IORD = IORDER PERTRB = 0.0 C C CHECK IF OPERATOR IS SINGULAR C CALL CHKSNG (MBDCND,NBDCND,ALPHA,BETA,GAMA,XNU,COFX,COFY,SINGLR) C C COMPUTE NON-ZERO EIGENVECTOR IN NULL SPACE OF TRANSPOSE C IF SINGULAR C IF (SINGLR) CALL TRISP (MIT,AM,BM,CM,DM,UM,ZM) IF (SINGLR) CALL TRISP (NIT,AN,BN,CN,DN,UN,ZN) C C MAKE INITIALIZATION CALL TO BLKTRI C IF (INTL .EQ. 0) 1 CALL BLKTRI (INTL,NP,NIT,AN,BN,CN,MP,MIT,AM,BM,CM,IDMN, 2 USOL(IS,JS),IERROR,W) IF (IERROR .NE. 0) RETURN C C ADJUST RIGHT HAND SIDE IF NECESSARY C 360 CONTINUE IF (SINGLR) CALL ORTHG (USOL,IDMN,ZN,ZM,PERTRB) C C COMPUTE SOLUTION C CALL BLKTRI (I1,NP,NIT,AN,BN,CN,MP,MIT,AM,BM,CM,IDMN,USOL(IS,JS), 1 IERROR,W) IF (IERROR .NE. 0) RETURN C C SET PERIODIC BOUNDARIES IF NECESSARY C IF (KSWX .NE. 1) GO TO 380 DO 370 J=1,L USOL(K,J) = USOL(1,J) 370 CONTINUE 380 IF (KSWY .NE. 1) GO TO 400 DO 390 I=1,K USOL(I,L) = USOL(I,1) 390 CONTINUE 400 CONTINUE C C MINIMIZE SOLUTION WITH RESPECT TO WEIGHTED LEAST SQUARES C NORM IF OPERATOR IS SINGULAR C IF (SINGLR) CALL MINSOL (USOL,IDMN,ZN,ZM,PRTRB) C C RETURN IF DEFERRED CORRECTIONS AND A FOURTH ORDER SOLUTION ARE C NOT FLAGGED C IF (IORD .EQ. 2) RETURN IORD = 2 C C COMPUTE NEW RIGHT HAND SIDE FOR FOURTH ORDER SOLUTION C CALL DEFER (COFX,COFY,USOL,IDMN,GRHS,MN) GO TO 360 END SUBROUTINE CHKPRM (INTL,IORDER,A,B,M,MBDCND,C,D,N,NBDCND,COFX, 1 COFY,IDMN,MN,IERROR) C C THIS PROGRAM CHECKS THE INPUT PARAMETERS FOR ERRORS C C C CHECK DEFINITION OF SOLUTION REGION C IERROR = 1 IF (A.GE.B .OR. C.GE.D) RETURN C C CHECK BOUNDARY SWITCHES C IERROR = 2 IF (MBDCND.LT.0 .OR. MBDCND.GT.4) RETURN IERROR = 3 IF (NBDCND.LT.0 .OR. NBDCND.GT.4) RETURN C C CHECK FIRST DIMENSION IN CALLING ROUTINE C IERROR = 5 IF (MN .LT. 7 .OR. IDMN .LT. 7) RETURN C C CHECK M C IERROR = 6 IF (M .GT. (IDMN-1) .OR. M.LT.6) RETURN IF (M .GT. MN - 1) RETURN C C CHECK N C IERROR = 7 IF (N .LT. 5) RETURN C C CHECK IORDER C IERROR = 8 IF (IORDER.NE.2 .AND. IORDER.NE.4) RETURN C C CHECK INTL C IERROR = 9 IF (INTL.NE.0 .AND. INTL.NE.1) RETURN C C CHECK THAT EQUATION IS ELLIPTIC C DLX = (B-A)/FLOAT(M) DLY = (D-C)/FLOAT(N) DO 30 I=2,M XI = A+FLOAT(I-1)*DLX CALL COFX (XI,AI,BI,CI) DO 20 J=2,N YJ = C+FLOAT(J-1)*DLY CALL COFY (YJ,DJ,EJ,FJ) IF (AI*DJ .GT. 0.0) GO TO 10 IERROR = 10 RETURN 10 CONTINUE 20 CONTINUE 30 CONTINUE C C NO ERROR FOUND C IERROR = 0 RETURN END SUBROUTINE CHKSNG (MBDCND,NBDCND,ALPHA,BETA,GAMA,XNU,COFX,COFY, 1 SINGLR) C C THIS SUBROUTINE CHECKS IF THE PDE SEPELL C MUST SOLVE IS A SINGULAR OPERATOR C LOGICAL SINGLR COMMON /SPLP/ KSWX ,KSWY ,K ,L , 1 AIT ,BIT ,CIT ,DIT , 2 MIT ,NIT ,IS ,MS , 3 JS ,NS ,DLX ,DLY , 4 TDLX3 ,TDLY3 ,DLX4 ,DLY4 C C SINGLR = .FALSE. C C CHECK IF THE BOUNDARY CONDITIONS ARE C ENTIRELY PERIODIC AND/OR MIXED C IF ((MBDCND.NE.0 .AND. MBDCND.NE.3) .OR. 1 (NBDCND.NE.0 .AND. NBDCND.NE.3)) RETURN C C CHECK THAT MIXED CONDITIONS ARE PURE NEUMAN C IF (MBDCND .NE. 3) GO TO 10 IF (ALPHA.NE.0.0 .OR. BETA.NE.0.0) RETURN 10 IF (NBDCND .NE. 3) GO TO 20 IF (GAMA.NE.0.0 .OR. XNU.NE.0.0) RETURN 20 CONTINUE C C CHECK THAT NON-DERIVATIVE COEFFICIENT FUNCTIONS C ARE ZERO C DO 30 I=IS,MS XI = AIT+FLOAT(I-1)*DLX CALL COFX (XI,AI,BI,CI) IF (CI .NE. 0.0) RETURN 30 CONTINUE DO 40 J=JS,NS YJ = CIT+FLOAT(J-1)*DLY CALL COFY (YJ,DJ,EJ,FJ) IF (FJ .NE. 0.0) RETURN 40 CONTINUE C C THE OPERATOR MUST BE SINGULAR IF THIS POINT IS REACHED C SINGLR = .TRUE. RETURN END SUBROUTINE ORTHG (USOL,IDMN,ZN,ZM,PERTRB) C C THIS SUBROUTINE ORTHOGONALIZES THE ARRAY USOL WITH RESPECT TO C THE CONSTANT ARRAY IN A WEIGHTED LEAST SQUARES NORM C DIMENSION USOL(IDMN,*) ,ZN(*) ,ZM(*) COMMON /SPLP/ KSWX ,KSWY ,K ,L , 1 AIT ,BIT ,CIT ,DIT , 2 MIT ,NIT ,IS ,MS , 3 JS ,NS ,DLX ,DLY , 4 TDLX3 ,TDLY3 ,DLX4 ,DLY4 C ISTR = IS IFNL = MS JSTR = JS JFNL = NS C C COMPUTE WEIGHTED INNER PRODUCTS C UTE = 0.0 ETE = 0.0 DO 20 I=IS,MS II = I-IS+1 DO 10 J=JS,NS JJ = J-JS+1 ETE = ETE+ZM(II)*ZN(JJ) UTE = UTE+USOL(I,J)*ZM(II)*ZN(JJ) 10 CONTINUE 20 CONTINUE C C SET PERTURBATION PARAMETER C PERTRB = UTE/ETE C C SUBTRACT OFF CONSTANT PERTRB C DO 40 I=ISTR,IFNL DO 30 J=JSTR,JFNL USOL(I,J) = USOL(I,J)-PERTRB 30 CONTINUE 40 CONTINUE RETURN END SUBROUTINE MINSOL (USOL,IDMN,ZN,ZM,PERTB) C C THIS SUBROUTINE ORTHOGONALIZES THE ARRAY USOL WITH RESPECT TO C THE CONSTANT ARRAY IN A WEIGHTED LEAST SQUARES NORM C DIMENSION USOL(IDMN,*) ,ZN(*) ,ZM(*) COMMON /SPLP/ KSWX ,KSWY ,K ,L , 1 AIT ,BIT ,CIT ,DIT , 2 MIT ,NIT ,IS ,MS , 3 JS ,NS ,DLX ,DLY , 4 TDLX3 ,TDLY3 ,DLX4 ,DLY4 C C ENTRY AT MINSOL OCCURRS WHEN THE FINAL SOLUTION IS C TO BE MINIMIZED WITH RESPECT TO THE WEIGHTED C LEAST SQUARES NORM C ISTR = 1 IFNL = K JSTR = 1 JFNL = L C C COMPUTE WEIGHTED INNER PRODUCTS C UTE = 0.0 ETE = 0.0 DO 20 I=IS,MS II = I-IS+1 DO 10 J=JS,NS JJ = J-JS+1 ETE = ETE+ZM(II)*ZN(JJ) UTE = UTE+USOL(I,J)*ZM(II)*ZN(JJ) 10 CONTINUE 20 CONTINUE C C SET PERTURBATION PARAMETER C PERTRB = UTE/ETE C C SUBTRACT OFF CONSTANT PERTRB C DO 40 I=ISTR,IFNL DO 30 J=JSTR,JFNL USOL(I,J) = USOL(I,J)-PERTRB 30 CONTINUE 40 CONTINUE RETURN END SUBROUTINE TRISP (N,A,B,C,D,U,Z) C C THIS SUBROUTINE SOLVES FOR A NON-ZERO EIGENVECTOR CORRESPONDING C TO THE ZERO EIGENVALUE OF THE TRANSPOSE OF THE RANK C DEFICIENT ONE MATRIX WITH SUBDIAGONAL A, DIAGONAL B, AND C SUPERDIAGONAL C , WITH A(1) IN THE (1,N) POSITION, WITH C C(N) IN THE (N,1) POSITION, AND ALL OTHER ELEMENTS ZERO. C DIMENSION A(N) ,B(N) ,C(N) ,D(N) , 1 U(N) ,Z(N) C BN = B(N) D(1) = A(2)/B(1) V = A(1) U(1) = C(N)/B(1) NM2 = N-2 DO 10 J=2,NM2 DEN = B(J)-C(J-1)*D(J-1) D(J) = A(J+1)/DEN U(J) = -C(J-1)*U(J-1)/DEN BN = BN-V*U(J-1) V = -V*D(J-1) 10 CONTINUE DEN = B(N-1)-C(N-2)*D(N-2) D(N-1) = (A(N)-C(N-2)*U(N-2))/DEN AN = C(N-1)-V*D(N-2) BN = BN-V*U(N-2) DEN = BN-AN*D(N-1) C C SET LAST COMPONENT EQUAL TO ONE C Z(N) = 1.0 Z(N-1) = -D(N-1) NM1 = N-1 DO 20 J=2,NM1 K = N-J Z(K) = -D(K)*Z(K+1)-U(K)*Z(N) 20 CONTINUE RETURN END SUBROUTINE DEFER (COFX,COFY,USOL,IDMN,GRHS,MN) C C THIS SUBROUTINE FIRST APPROXIMATES THE TRUNCATION ERROR GIVEN C BY TRUN1(X,Y)=DLX**2*TX+DLY**2*TY WHERE C TX=AFUN(X)*UXXXX/12.0+BFUN(X)*UXXX/6.0 ON THE INTERIOR AND C AT THE BOUNDARIES IF PERIODIC (HERE UXXX,UXXXX ARE THE THIRD C AND FOURTH PARTIAL DERIVATIVES OF U WITH RESPECT TO X). C TX IS OF THE FORM AFUN(X)/3.0*(UXXXX/4.0+UXXX/DLX) C AT X=A OR X=B IF THE BOUNDARY CONDITION THERE IS MIXED. C TX=0.0 ALONG SPECIFIED BOUNDARIES. TY HAS SYMMETRIC FORM C IN Y WITH X,AFUN(X),BFUN(X) REPLACED BY Y,DFUN(Y),EFUN(Y). C THE SECOND ORDER SOLUTION IN USOL IS USED TO APPROXIMATE C (VIA SECOND ORDER FINITE DIFFERENCING) THE TRUN1ATION ERROR C AND THE RESULT IS ADDED TO THE RIGHT HAND SIDE IN GRHS C AND THEN TRANSFERRED TO USOL TO BE USED AS A NEW RIGHT C HAND SIDE WHEN CALLING BLKTRI FOR A FOURTH ORDER SOLUTION. C DIMENSION GRHS(MN,*) ,USOL(IDMN,*) COMMON /SPLP/ KSWX ,KSWY ,K ,L , 1 AIT ,BIT ,CIT ,DIT , 2 MIT ,NIT ,IS ,MS , 3 JS ,NS ,DLX ,DLY , 4 TDLX3 ,TDLY3 ,DLX4 ,DLY4 C C C COMPUTE TRUNCATION ERROR APPROXIMATION OVER THE ENTIRE MESH C DO 40 J=JS,NS YJ = CIT+FLOAT(J-1)*DLY CALL COFY (YJ,DJ,EJ,FJ) DO 30 I=IS,MS XI = AIT+FLOAT(I-1)*DLX CALL COFX (XI,AI,BI,CI) C C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT (XI,YJ) C CALL DXFN (USOL,IDMN,I,J,UXXX,UXXXX) CALL DYFN (USOL,IDMN,I,J,UYYY,UYYYY) TX = AI*UXXXX/12.0+BI*UXXX/6.0 TY = DJ*UYYYY/12.0+EJ*UYYY/6.0 C C RESET FORM OF TRUNCATION IF AT BOUNDARY WHICH IS NON-PERIODIC C IF (KSWX.EQ.1 .OR. (I.GT.1 .AND. I.LT.K)) GO TO 10 TX = AI/3.0*(UXXXX/4.0+UXXX/DLX) 10 IF (KSWY.EQ.1 .OR. (J.GT.1 .AND. J.LT.L)) GO TO 20 TY = DJ/3.0*(UYYYY/4.0+UYYY/DLY) 20 GRHS(I,J) = GRHS(I,J)+DLX**2*TX+DLY**2*TY 30 CONTINUE 40 CONTINUE C C RESET THE RIGHT HAND SIDE IN USOL C DO 60 I=IS,MS DO 50 J=JS,NS USOL(I,J) = GRHS(I,J) 50 CONTINUE 60 CONTINUE RETURN END SUBROUTINE DXFN (U,IDMN,I,J,UXXX,UXXXX) C C THIS PROGRAM COMPUTES SECOND ORDER FINITE DIFFERENCE C APPROXIMATIONS TO THE THIRD AND FOURTH X C PARTIAL DERIVATIVES OF U AT THE (I,J) MESH POINT C DIMENSION U(IDMN,*) COMMON /SPLP/ KSWX ,KSWY ,K ,L , 1 AIT ,BIT ,CIT ,DIT , 2 MIT ,NIT ,IS ,MS , 3 JS ,NS ,DLX ,DLY , 4 TDLX3 ,TDLY3 ,DLX4 ,DLY4 C IF (I.GT.2 .AND. I.LT.(K-1)) GO TO 50 IF (I .EQ. 1) GO TO 10 IF (I .EQ. 2) GO TO 30 IF (I .EQ. K-1) GO TO 60 IF (I .EQ. K) GO TO 80 C C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT X=A C 10 IF (KSWX .EQ. 1) GO TO 20 UXXX = (-5.0*U(1,J)+18.0*U(2,J)-24.0*U(3,J)+14.0*U(4,J)- 1 3.0*U(5,J))/(TDLX3) UXXXX = (3.0*U(1,J)-14.0*U(2,J)+26.0*U(3,J)-24.0*U(4,J)+ 1 11.0*U(5,J)-2.0*U(6,J))/DLX4 RETURN C C PERIODIC AT X=A C 20 UXXX = (-U(K-2,J)+2.0*U(K-1,J)-2.0*U(2,J)+U(3,J))/(TDLX3) UXXXX = (U(K-2,J)-4.0*U(K-1,J)+6.0*U(1,J)-4.0*U(2,J)+U(3,J))/DLX4 RETURN C C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT X=A+DLX C 30 IF (KSWX .EQ. 1) GO TO 40 UXXX = (-3.0*U(1,J)+10.0*U(2,J)-12.0*U(3,J)+6.0*U(4,J)-U(5,J))/ 1 TDLX3 UXXXX = (2.0*U(1,J)-9.0*U(2,J)+16.0*U(3,J)-14.0*U(4,J)+6.0*U(5,J)- 1 U(6,J))/DLX4 RETURN C C PERIODIC AT X=A+DLX C 40 UXXX = (-U(K-1,J)+2.0*U(1,J)-2.0*U(3,J)+U(4,J))/(TDLX3) UXXXX = (U(K-1,J)-4.0*U(1,J)+6.0*U(2,J)-4.0*U(3,J)+U(4,J))/DLX4 RETURN C C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS ON THE INTERIOR C 50 CONTINUE UXXX = (-U(I-2,J)+2.0*U(I-1,J)-2.0*U(I+1,J)+U(I+2,J))/TDLX3 UXXXX = (U(I-2,J)-4.0*U(I-1,J)+6.0*U(I,J)-4.0*U(I+1,J)+U(I+2,J))/ 1 DLX4 RETURN C C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT X=B-DLX C 60 IF (KSWX .EQ. 1) GO TO 70 UXXX = (U(K-4,J)-6.0*U(K-3,J)+12.0*U(K-2,J)-10.0*U(K-1,J)+ 1 3.0*U(K,J))/TDLX3 UXXXX = (-U(K-5,J)+6.0*U(K-4,J)-14.0*U(K-3,J)+16.0*U(K-2,J)- 1 9.0*U(K-1,J)+2.0*U(K,J))/DLX4 RETURN C C PERIODIC AT X=B-DLX C 70 UXXX = (-U(K-3,J)+2.0*U(K-2,J)-2.0*U(1,J)+U(2,J))/TDLX3 UXXXX = (U(K-3,J)-4.0*U(K-2,J)+6.0*U(K-1,J)-4.0*U(1,J)+U(2,J))/ 1 DLX4 RETURN C C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT X=B C 80 UXXX = -(3.0*U(K-4,J)-14.0*U(K-3,J)+24.0*U(K-2,J)-18.0*U(K-1,J)+ 1 5.0*U(K,J))/TDLX3 UXXXX = (-2.0*U(K-5,J)+11.0*U(K-4,J)-24.0*U(K-3,J)+26.0*U(K-2,J)- 1 14.0*U(K-1,J)+3.0*U(K,J))/DLX4 RETURN END SUBROUTINE DYFN (U,IDMN,I,J,UYYY,UYYYY) C C THIS PROGRAM COMPUTES SECOND ORDER FINITE DIFFERENCE C APPROXIMATIONS TO THE THIRD AND FOURTH Y C PARTIAL DERIVATIVES OF U AT THE (I,J) MESH POINT C DIMENSION U(IDMN,*) COMMON /SPLP/ KSWX ,KSWY ,K ,L , 1 AIT ,BIT ,CIT ,DIT , 2 MIT ,NIT ,IS ,MS , 3 JS ,NS ,DLX ,DLY , 4 TDLX3 ,TDLY3 ,DLX4 ,DLY4 C IF (J.GT.2 .AND. J.LT.(L-1)) GO TO 50 IF (J .EQ. 1) GO TO 10 IF (J .EQ. 2) GO TO 30 IF (J .EQ. L-1) GO TO 60 IF (J .EQ. L) GO TO 80 C C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT Y=C C 10 IF (KSWY .EQ. 1) GO TO 20 UYYY = (-5.0*U(I,1)+18.0*U(I,2)-24.0*U(I,3)+14.0*U(I,4)- 1 3.0*U(I,5))/TDLY3 UYYYY = (3.0*U(I,1)-14.0*U(I,2)+26.0*U(I,3)-24.0*U(I,4)+ 1 11.0*U(I,5)-2.0*U(I,6))/DLY4 RETURN C C PERIODIC AT X=A C 20 UYYY = (-U(I,L-2)+2.0*U(I,L-1)-2.0*U(I,2)+U(I,3))/TDLY3 UYYYY = (U(I,L-2)-4.0*U(I,L-1)+6.0*U(I,1)-4.0*U(I,2)+U(I,3))/DLY4 RETURN C C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT Y=C+DLY C 30 IF (KSWY .EQ. 1) GO TO 40 UYYY = (-3.0*U(I,1)+10.0*U(I,2)-12.0*U(I,3)+6.0*U(I,4)-U(I,5))/ 1 TDLY3 UYYYY = (2.0*U(I,1)-9.0*U(I,2)+16.0*U(I,3)-14.0*U(I,4)+6.0*U(I,5)- 1 U(I,6))/DLY4 RETURN C C PERIODIC AT Y=C+DLY C 40 UYYY = (-U(I,L-1)+2.0*U(I,1)-2.0*U(I,3)+U(I,4))/TDLY3 UYYYY = (U(I,L-1)-4.0*U(I,1)+6.0*U(I,2)-4.0*U(I,3)+U(I,4))/DLY4 RETURN C C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS ON THE INTERIOR C 50 CONTINUE UYYY = (-U(I,J-2)+2.0*U(I,J-1)-2.0*U(I,J+1)+U(I,J+2))/TDLY3 UYYYY = (U(I,J-2)-4.0*U(I,J-1)+6.0*U(I,J)-4.0*U(I,J+1)+U(I,J+2))/ 1 DLY4 RETURN C C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT Y=D-DLY C 60 IF (KSWY .EQ. 1) GO TO 70 UYYY = (U(I,L-4)-6.0*U(I,L-3)+12.0*U(I,L-2)-10.0*U(I,L-1)+ 1 3.0*U(I,L))/TDLY3 UYYYY = (-U(I,L-5)+6.0*U(I,L-4)-14.0*U(I,L-3)+16.0*U(I,L-2)- 1 9.0*U(I,L-1)+2.0*U(I,L))/DLY4 RETURN C C PERIODIC AT Y=D-DLY C 70 CONTINUE UYYY = (-U(I,L-3)+2.0*U(I,L-2)-2.0*U(I,1)+U(I,2))/TDLY3 UYYYY = (U(I,L-3)-4.0*U(I,L-2)+6.0*U(I,L-1)-4.0*U(I,1)+U(I,2))/ 1 DLY4 RETURN C C COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT Y=D C 80 UYYY = -(3.0*U(I,L-4)-14.0*U(I,L-3)+24.0*U(I,L-2)-18.0*U(I,L-1)+ 1 5.0*U(I,L))/TDLY3 UYYYY = (-2.0*U(I,L-5)+11.0*U(I,L-4)-24.0*U(I,L-3)+26.0*U(I,L-2)- 1 14.0*U(I,L-1)+3.0*U(I,L))/DLY4 RETURN END SUBROUTINE BLKTRI (IFLG,NP,N,AN,BN,CN,MP,M,AM,BM,CM,IDIMY,Y, 1 IERROR,W) C C C*********************************************************************** C C VERSION 2 OCTOBER 1976 INCLUDING ERRATA OCTOBER 1976 C C DOCUMENTATION FOR THIS PROGRAM IS GIVEN IN C C EFFICIENT FORTRAN SUBPROGRAMS FOR THE SOLUTION OF C ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS C C BY C C PAUL SWARZTRAUBER AND ROLAND SWEET C C TECHNICAL NOTE TN/IA-109 JULY 1975 C C NATIONAL CENTER FOR ATMOSPHERIC RESEARCH BOULDER,COLORADO 80307 C C WHICH IS SPONSORED BY THE NATIONAL SCIENCE FOUNDATION C C*********************************************************************** C C C C SUBROUTINE BLKTRI SOLVES A SYSTEM OF LINEAR EQUATIONS OF THE FORM C C AN(J)*X(I,J-1) + AM(I)*X(I-1,J) + (BN(J)+BM(I))*X(I,J) C C + CN(J)*X(I,J+1) + CM(I)*X(I+1,J) = Y(I,J) C C FOR I = 1,2,...,M AND J = 1,2,...,N. C C I+1 AND I-1 ARE EVALUATED MODULO M AND J+1 AND J-1 MODULO N, I.E., C C X(I,0) = X(I,N), X(I,N+1) = X(I,1), C X(0,J) = X(M,J), X(M+1,J) = X(1,J). C C THESE EQUATIONS USUALLY RESULT FROM THE DISCRETIZATION OF C SEPARABLE ELLIPTIC EQUATIONS. BOUNDARY CONDITIONS MAY BE C DIRICHLET, NEUMANN, OR PERIODIC. C C C * * * * * * * * * * ON INPUT * * * * * * * * * * C C IFLG C = 0 INITIALIZATION ONLY. CERTAIN QUANTITIES THAT DEPEND ON NP, C N, AN, BN, AND CN ARE COMPUTED AND C STOR1D IN THE WORK ARRAY W. C = 1 THE QUANTITIES THAT WERE COMPUTED IN THE INITIALIZATION ARE C USED TO OBTAIN THE SOLUTION X(I,J). C C NOTE A CALL WITH IFLG=0 TAKES APPROXIMATELY ONE HALF THE TIME C TIME AS A CALL WITH IFLG = 1 . HOWEVER, THE C INITIALIZATION DOES NOT HAVE TO BE REPEATED UNLESS NP, N, C AN, BN, OR CN CHANGE. C C NP C = 0 IF AN(1) AND CN(N) ARE NOT ZERO, WHICH CORRESPONDS TO C PERIODIC BOUNARY CONDITIONS. C = 1 IF AN(1) AND CN(N) ARE ZERO. C C N C THE NUMBER OF UNKNOWNS IN THE J-DIRECTION. N MUST BE GREATER C THAN 2. THE OPERATION COUNT IS PROPORTIONAL TO MNLOG2(N), HENCE C N SHOULD BE SELECTED LESS THAN OR EQUAL TO M. C C AN,BN,CN C ONE-DIMENSIONAL ARRAYS OF LENGTH N THAT SPECIFY THE COEFFICIENTS C IN THE LINEAR EQUATIONS GIVEN ABOVE. C C MP C = 0 IF AM(1) AND CM(M) ARE NOT ZERO, WHICH CORRESPONDS TO C PERIODIC BOUNDARY CONDITIONS. C = 1 IF AM(1) = CM(M) = 0 . C C M C THE NUMBER OF UNKNOWNS IN THE I-DIRECTION. M MUST BE GREATER C THAN 2. C C AM,BM,CM C ONE-DIMENSIONAL ARRAYS OF LENGTH M THAT SPECIFY THE COEFFICIENTS C IN THE LINEAR EQUATIONS GIVEN ABOVE. C C IDIMY C THE ROW (OR FIRST) DIMENSION OF THE TWO-DIMENSIONAL ARRAY Y AS C IT APPEARS IN THE PROGRAM CALLING BLKTRI. THIS PARAMETER IS C USED TO SPECIFY THE VARIABLE DIMENSION OF Y. IDIMY MUST BE AT C LEAST M. C C Y C A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE VALUES OF THE RIGHT C SIDE OF THE LINEAR SYSTEM OF EQUATIONS GIVEN ABOVE. Y MUST BE C DIMENSIONED AT LEAST M*N. C C W C A ONE-DIMENSIONAL ARRAY THAT MUST BE PROVIDED BY THE USER FOR C WORK SPACE. C IF NP=1 DEFINE K=INT(LOG2(N))+1 AND SET L=2**(K+1) THEN C W MUST HAVE DIMENSION (K-2)*L+K+4+MAX(2N,6M) C C IF NP=0 DEFINE K=INT(LOG2(N-1))+1 AND SET L=2**(K+1) THEN C W MUST HAVE DIMENSION (K-2)*L+K+4+2N+MAX(2N,6M) C C **IMPORTANT** FOR PURPOSES OF CHECKING, THE REQUIRED DIMENSION C OF W IS COMPUTED BY BLKTRI AND STOR1D IN W(1) C IN FLOATING POINT FORMAT. C C * * * * * * * * * * ON OUTPUT * * * * * * * * * * C C Y C CONTAINS THE SOLUTION X. C C IERROR C AN ERROR FLAG THAT INDICATES INVALID INPUT PARAMETERS. EXCEPT C FOR NUMBER ZERO, A SOLUTION IS NOT ATTEMPTED. C C = 0 NO ERROR. C = 1 M IS LESS THAN 5 C = 2 N IS LESS THAN 3. C = 3 IDIMY IS LESS THAN M. C = 4 BLKTRI FAILED WHILE COMPUTING RESULTS THAT DEPEND ON THE C COEFFICIENT ARRAYS AN, BN, CN. CHECK THESE ARRAYS. C = 5 AN(J)*CN(J-1) IS LESS THAN 0 FOR SOME J. POSSIBLE REASONS C FOR THIS CONDITION ARE C 1. THE ARRAYS AN AND CN ARE NOT CORRECT C 2. TOO LARGE A GRID SPACING WAS USED IN THE DISCRETIZATION C OF THE ELLIPTIC EQUATION C 3. THE LINEAR EQUATIONS RESULTED FROM A PARTIAL C DIFFERENTIAL EQUATION WHICH WAS NOT ELLIPTIC C C W C CONTAINS INTERMEDIATE VALUES THAT MUST NOT BE DESTROYED IF C BLKTRI WILL BE CALLED AGAIN WITH IFLG = 1 . C C C DIMENSION AN(*) ,BN(*) ,CN(*) ,AM(*) , 1 BM(*) ,CM(*) ,Y(IDIMY,*) ,W(*) EXTERNAL PROD0 ,PRODP ,CPROD0 ,CPRODP COMMON /CBLKT/ NPP ,K ,EPS ,CNV , 1 NM ,NCMPLX ,IK C C TEST M AND N FOR THE PROPER FORM C NM = N IERROR = 0 IF (M-5) 10, 20, 20 10 IERROR = 1 GO TO 190 20 IF (NM-3) 30, 40, 40 30 IERROR = 2 GO TO 190 40 IF (IDIMY-M) 50, 60, 60 50 IERROR = 3 GO TO 190 60 NH = N NPP = NP IF (NPP) 70, 80, 70 70 NH = NH+1 80 IK = 2 K = 1 90 IK = IK+IK K = K+1 IF (NH-IK) 100,100, 90 100 NL = IK IK = IK+IK NL = NL-1 IWAH = (K-2)*IK+K+6 IF (NPP) 110,120,110 C C DIVIDE W INTO WORKING SUB ARRAYS C 110 IW1 = IWAH IWBH = IW1+NM W(1) = FLOAT(IW1-1+MAX0(2*NM,6*M)) GO TO 130 120 IWBH = IWAH+NM+NM IW1 = IWBH W(1) = FLOAT(IW1-1+MAX0(2*NM,6*M)) NM = NM-1 C C SUBROUTINE COMPB COMPUTES THE ROOTS OF THE B POLYNOMIALS C 130 IF (IERROR) 190,140,190 140 IW2 = IW1+M IW3 = IW2+M IWD = IW3+M IWW = IWD+M IWU = IWW+M IF (IFLG) 160,150,160 150 CALL COMPB (NL,IERROR,AN,BN,CN,W(2),W(IWAH),W(IWBH)) GO TO 190 160 IF (MP) 170,180,170 C C SUBROUTINE BLKTR1 SOLVES THE LINEAR SYSTEM C 170 CALL BLKTR1 (NL,AN,BN,CN,M,AM,BM,CM,IDIMY,Y,W(2),W(IW1),W(IW2), 1 W(IW3),W(IWD),W(IWW),W(IWU),PROD0,CPROD0) GO TO 190 180 CALL BLKTR1 (NL,AN,BN,CN,M,AM,BM,CM,IDIMY,Y,W(2),W(IW1),W(IW2), 1 W(IW3),W(IWD),W(IWW),W(IWU),PRODP,CPRODP) 190 CONTINUE RETURN END SUBROUTINE BLKTR1 (N,AN,BN,CN,M,AM,BM,CM,IDIMY,Y,B,W1,W2,W3,WD, 1 WW,WU,PRDCT,CPRDCT) C C BLKTR1 SOLVES THE LINEAR SYSTEM C C B CONTAINS THE ROOTS OF ALL THE B POLYNOMIALS C W1,W2,W3,WD,WW,WU ARE ALL WORKING ARRAYS C PRDCT IS EITHER PRODP OR PROD0 DEPENDING ON WHETHER THE BOUNDARY C CONDITIONS IN THE M DIRECTION ARE PERIODIC OR NOT C CPRDCT IS EITHER CPRODP OR CPROD0 WHICH ARE THE COMPLEX VERSIONS C OF PRODP AND PROD0. THESE ARE CALLED IN THE EVENT THAT SOME C OF THE ROOTS OF THE B SUB P POLYNOMIAL ARE COMPLEX C C DIMENSION AN(*) ,BN(*) ,CN(*) ,AM(*) , 1 BM(*) ,CM(*) ,B(*) ,W1(*) , 2 W2(*) ,W3(*) ,WD(*) ,WW(*) , 3 WU(*) ,Y(IDIMY,*) COMMON /CBLKT/ NPP ,K ,EPS ,CNV , 1 NM ,NCMPLX ,IK C C BEGIN REDUCTION PHASE C KDO = K-1 DO 90 L=1,KDO IR = L-1 I2 = 2**IR I1 = I2/2 I3 = I2+I1 I4 = I2+I2 IRM1 = IR-1 CALL INDXB (I2,IR,IM2,NM2) CALL INDXB (I1,IRM1,IM3,NM3) CALL INDXB (I3,IRM1,IM1,NM1) CALL PRDCT (NM2,B(IM2),NM3,B(IM3),NM1,B(IM1),0,DUM,Y(1,I2),W3, 1 M,AM,BM,CM,WD,WW,WU) IF = 2**K DO 80 I=I4,IF,I4 IF (I-NM) 10, 10, 80 10 IPI1 = I+I1 IPI2 = I+I2 IPI3 = I+I3 CALL INDXC (I,IR,IDXC,NC) IF (I-IF) 20, 80, 80 20 CALL INDXA (I,IR,IDXA,NA) CALL INDXB (I-I1,IRM1,IM1,NM1) CALL INDXB (IPI2,IR,IP2,NP2) CALL INDXB (IPI1,IRM1,IP1,NP1) CALL INDXB (IPI3,IRM1,IP3,NP3) CALL PRDCT (NM1,B(IM1),0,DUM,0,DUM,NA,AN(IDXA),W3,W1,M,AM, 1 BM,CM,WD,WW,WU) IF (IPI2-NM) 50, 50, 30 30 DO 40 J=1,M W3(J) = 0. W2(J) = 0. 40 CONTINUE GO TO 60 50 CALL PRDCT (NP2,B(IP2),NP1,B(IP1),NP3,B(IP3),0,DUM, 1 Y(1,IPI2),W3,M,AM,BM,CM,WD,WW,WU) CALL PRDCT (NP1,B(IP1),0,DUM,0,DUM,NC,CN(IDXC),W3,W2,M,AM, 1 BM,CM,WD,WW,WU) 60 DO 70 J=1,M Y(J,I) = W1(J)+W2(J)+Y(J,I) 70 CONTINUE 80 CONTINUE 90 CONTINUE IF (NPP) 320,100,320 C C THE PERIODIC CASE IS TREATED USING THE CAPACITANCE MATRIX METHOD C 100 IF = 2**K I = IF/2 I1 = I/2 CALL INDXB (I-I1,K-2,IM1,NM1) CALL INDXB (I+I1,K-2,IP1,NP1) CALL INDXB (I,K-1,IZ,NZ) CALL PRDCT (NZ,B(IZ),NM1,B(IM1),NP1,B(IP1),0,DUM,Y(1,I),W1,M,AM, 1 BM,CM,WD,WW,WU) IZR = I DO 110 J=1,M W2(J) = W1(J) 110 CONTINUE DO 130 LL=2,K L = K-LL+1 IR = L-1 I2 = 2**IR I1 = I2/2 I = I2 CALL INDXC (I,IR,IDXC,NC) CALL INDXB (I,IR,IZ,NZ) CALL INDXB (I-I1,IR-1,IM1,NM1) CALL INDXB (I+I1,IR-1,IP1,NP1) CALL PRDCT (NP1,B(IP1),0,DUM,0,DUM,NC,CN(IDXC),W1,W1,M,AM,BM, 1 CM,WD,WW,WU) DO 120 J=1,M W1(J) = Y(J,I)+W1(J) 120 CONTINUE CALL PRDCT (NZ,B(IZ),NM1,B(IM1),NP1,B(IP1),0,DUM,W1,W1,M,AM, 1 BM,CM,WD,WW,WU) 130 CONTINUE DO 180 LL=2,K L = K-LL+1 IR = L-1 I2 = 2**IR I1 = I2/2 I4 = I2+I2 IFD = IF-I2 DO 170 I=I2,IFD,I4 IF (I-I2-IZR) 170,140,170 140 IF (I-NM) 150,150,180 150 CALL INDXA (I,IR,IDXA,NA) CALL INDXB (I,IR,IZ,NZ) CALL INDXB (I-I1,IR-1,IM1,NM1) CALL INDXB (I+I1,IR-1,IP1,NP1) CALL PRDCT (NM1,B(IM1),0,DUM,0,DUM,NA,AN(IDXA),W2,W2,M,AM, 1 BM,CM,WD,WW,WU) DO 160 J=1,M W2(J) = Y(J,I)+W2(J) 160 CONTINUE CALL PRDCT (NZ,B(IZ),NM1,B(IM1),NP1,B(IP1),0,DUM,W2,W2,M, 1 AM,BM,CM,WD,WW,WU) IZR = I IF (I-NM) 170,190,170 170 CONTINUE 180 CONTINUE 190 DO 200 J=1,M Y(J,NM+1) = Y(J,NM+1)-CN(NM+1)*W1(J)-AN(NM+1)*W2(J) 200 CONTINUE CALL INDXB (IF/2,K-1,IM1,NM1) CALL INDXB (IF,K-1,IP,NP) IF (NCMPLX) 210,220,210 210 CALL CPRDCT (NM+1,B(IP),NM1,B(IM1),0,DUM,0,DUM,Y(1,NM+1), 1 Y(1,NM+1),M,AM,BM,CM,W1,W3,WW) GO TO 230 220 CALL PRDCT (NM+1,B(IP),NM1,B(IM1),0,DUM,0,DUM,Y(1,NM+1), 1 Y(1,NM+1),M,AM,BM,CM,WD,WW,WU) 230 DO 240 J=1,M W1(J) = AN(1)*Y(J,NM+1) W2(J) = CN(NM)*Y(J,NM+1) Y(J,1) = Y(J,1)-W1(J) Y(J,NM) = Y(J,NM)-W2(J) 240 CONTINUE DO 260 L=1,KDO IR = L-1 I2 = 2**IR I4 = I2+I2 I1 = I2/2 I = I4 CALL INDXA (I,IR,IDXA,NA) CALL INDXB (I-I2,IR,IM2,NM2) CALL INDXB (I-I2-I1,IR-1,IM3,NM3) CALL INDXB (I-I1,IR-1,IM1,NM1) CALL PRDCT (NM2,B(IM2),NM3,B(IM3),NM1,B(IM1),0,DUM,W1,W1,M,AM, 1 BM,CM,WD,WW,WU) CALL PRDCT (NM1,B(IM1),0,DUM,0,DUM,NA,AN(IDXA),W1,W1,M,AM,BM, 1 CM,WD,WW,WU) DO 250 J=1,M Y(J,I) = Y(J,I)-W1(J) 250 CONTINUE 260 CONTINUE C IZR = NM DO 310 L=1,KDO IR = L-1 I2 = 2**IR I1 = I2/2 I3 = I2+I1 I4 = I2+I2 IRM1 = IR-1 DO 300 I=I4,IF,I4 IPI1 = I+I1 IPI2 = I+I2 IPI3 = I+I3 IF (IPI2-IZR) 270,280,270 270 IF (I-IZR) 300,310,300 280 CALL INDXC (I,IR,IDXC,NC) CALL INDXB (IPI2,IR,IP2,NP2) CALL INDXB (IPI1,IRM1,IP1,NP1) CALL INDXB (IPI3,IRM1,IP3,NP3) CALL PRDCT (NP2,B(IP2),NP1,B(IP1),NP3,B(IP3),0,DUM,W2,W2,M, 1 AM,BM,CM,WD,WW,WU) CALL PRDCT (NP1,B(IP1),0,DUM,0,DUM,NC,CN(IDXC),W2,W2,M,AM, 1 BM,CM,WD,WW,WU) DO 290 J=1,M Y(J,I) = Y(J,I)-W2(J) 290 CONTINUE IZR = I GO TO 310 300 CONTINUE 310 CONTINUE C C BEGIN BACK SUBSTITUTION PHASE C 320 DO 440 LL=1,K L = K-LL+1 IR = L-1 IRM1 = IR-1 I2 = 2**IR I1 = I2/2 I4 = I2+I2 IFD = IF-I2 DO 430 I=I2,IFD,I4 IF (I-NM) 330,330,430 330 IMI1 = I-I1 IMI2 = I-I2 IPI1 = I+I1 IPI2 = I+I2 CALL INDXA (I,IR,IDXA,NA) CALL INDXC (I,IR,IDXC,NC) CALL INDXB (I,IR,IZ,NZ) CALL INDXB (IMI1,IRM1,IM1,NM1) CALL INDXB (IPI1,IRM1,IP1,NP1) IF (I-I2) 340,340,360 340 DO 350 J=1,M W1(J) = 0. 350 CONTINUE GO TO 370 360 CALL PRDCT (NM1,B(IM1),0,DUM,0,DUM,NA,AN(IDXA),Y(1,IMI2), 1 W1,M,AM,BM,CM,WD,WW,WU) 370 IF (IPI2-NM) 400,400,380 380 DO 390 J=1,M W2(J) = 0. 390 CONTINUE GO TO 410 400 CALL PRDCT (NP1,B(IP1),0,DUM,0,DUM,NC,CN(IDXC),Y(1,IPI2), 1 W2,M,AM,BM,CM,WD,WW,WU) 410 DO 420 J=1,M W1(J) = Y(J,I)+W1(J)+W2(J) 420 CONTINUE CALL PRDCT (NZ,B(IZ),NM1,B(IM1),NP1,B(IP1),0,DUM,W1,Y(1,I), 1 M,AM,BM,CM,WD,WW,WU) 430 CONTINUE 440 CONTINUE RETURN END SUBROUTINE INDXA (I,IR,IDXA,NA) COMMON /CBLKT/ NPP ,K ,EPS ,CNV , 1 NM ,NCMPLX ,IK C NA = 2**IR IDXA = I-NA+1 IF (I-NM) 20, 20, 10 10 NA = 0 20 RETURN END SUBROUTINE INDXC (I,IR,IDXC,NC) COMMON /CBLKT/ NPP ,K ,EPS ,CNV , 1 NM ,NCMPLX ,IK C NC = 2**IR IDXC = I IF (IDXC+NC-1-NM) 20, 20, 10 10 NC = 0 20 RETURN END SUBROUTINE INDXB (I,IR,IDX,IDP) C C B(IDX) IS THE LOCATION OF THE FIRST ROOT OF THE B(I,IR) POLYNOMIAL C COMMON /CBLKT/ NPP ,K ,EPS ,CNV , 1 NM ,NCMPLX ,IK C IDP = 0 IF (IR) 70, 10, 30 10 IF (I-NM) 20, 20, 70 20 IDX = I IDP = 1 RETURN 30 IZH = 2**IR ID = I-IZH-IZH IDX = ID+ID+(IR-1)*IK+IR+(IK-I)/IZH+4 IPL = IZH-1 IDP = IZH+IZH-1 IF (I-IPL-NM) 50, 50, 40 40 IDP = 0 RETURN 50 IF (I+IPL-NM) 70, 70, 60 60 IDP = NM+IPL-I+1 70 RETURN END SUBROUTINE PROD0 (ND,BD,NM1,BM1,NM2,BM2,NA,AA,X,Y,M,A,B,C,D,W,U) C C PROD0 APPLIES A SEQUENCE OF MATRIX OPERATIONS TO THE VECTOR X AND C STORES THE RESULT IN Y. C C BD,BM1,BM2 ARRAYS CONTAINING ROOTS OF CERTIAN B POLYNOMIALS. C ND,NM1,NM2 THE LENGTHS OF THE ARRAYS BD,BM1,BM2 RESPECTIVELY. C AA ARRAY CONTAINING SCALAR MULTIPLIERS OF THE VECTOR X. C NA THE LENGTH OF THE ARRAY AA. C X,Y MATRIX OPERATIONS ARE APPLIED TO X AND THE RESULT IS Y. C A,B,C ARRAYS WHICH CONTAIN THE TRIDIAGONAL MATRIX. C M THE ORDER OF THE MATRIX. C D,W,U WORKING ARRAYS. C IS DETERMINES WHETHER OR NOT A CHANGE IN SIGN IS MADE. C DIMENSION A(*) ,B(*) ,C(*) ,X(*) , 1 Y(*) ,D(*) ,W(*) ,BD(*) , 2 BM1(*) ,BM2(*) ,AA(*) ,U(*) C DO 10 J=1,M W(J) = X(J) Y(J) = W(J) 10 CONTINUE MM = M-1 ID = ND IBR = 0 M1 = NM1 M2 = NM2 IA = NA 20 IF (IA) 50, 50, 30 30 RT = AA(IA) IF (ND .EQ. 0) RT = -RT IA = IA-1 C C SCALAR MULTIPLICATION C DO 40 J=1,M Y(J) = RT*W(J) 40 CONTINUE 50 IF (ID) 250,250, 60 60 RT = BD(ID) ID = ID-1 IF (ID .EQ. 0) IBR = 1 C C BEGIN SOLUTION TO SYSTEM C D(M) = A(M)/(B(M)-RT) W(M) = Y(M)/(B(M)-RT) DO 70 J=2,MM K = M-J DEN = B(K+1)-RT-C(K+1)*D(K+2) D(K+1) = A(K+1)/DEN W(K+1) = (Y(K+1)-C(K+1)*W(K+2))/DEN 70 CONTINUE DEN = B(1)-RT-C(1)*D(2) W(1) = 1. IF (DEN) 80, 90, 80 80 W(1) = (Y(1)-C(1)*W(2))/DEN 90 DO 100 J=2,M W(J) = W(J)-D(J)*W(J-1) 100 CONTINUE IF (NA) 130,130, 20 110 DO 120 J=1,M Y(J) = W(J) 120 CONTINUE IBR = 1 GO TO 20 130 IF (M1) 140,140,150 140 IF (M2) 110,110,200 150 IF (M2) 170,170,160 160 IF (ABS(BM1(M1))-ABS(BM2(M2))) 200,200,170 170 IF (IBR) 180,180,190 180 IF (ABS(BM1(M1)-BD(ID))-ABS(BM1(M1)-RT)) 110,190,190 190 RT = RT-BM1(M1) M1 = M1-1 GO TO 230 200 IF (IBR) 210,210,220 210 IF (ABS(BM2(M2)-BD(ID))-ABS(BM2(M2)-RT)) 110,220,220 220 RT = RT-BM2(M2) M2 = M2-1 230 DO 240 J=1,M Y(J) = Y(J)+RT*W(J) 240 CONTINUE GO TO 20 250 RETURN END SUBROUTINE PRODP (ND,BD,NM1,BM1,NM2,BM2,NA,AA,X,Y,M,A,B,C,D,U,W) C C PRODP APPLIES A SEQUENCE OF MATRIX OPERATIONS TO THE VECTOR X AND C STORES THE RESULT IN Y. (PERIODIC BOUNDARY CONDITIONS) C C BD,BM1,BM2 ARRAYS CONTAINING ROOTS OF CERTIAN B POLYNOMIALS. C ND,NM1,NM2 THE LENGTHS OF THE ARRAYS BD,BM1,BM2 RESPECTIVELY. C AA ARRAY CONTAINING SCALAR MULTIPLIERS OF THE VECTOR X. C NA LENGTH OF THE ARRAY AA. C X,Y MATRIX OPERATIONS ARE APPLIED TO X AND THE RESULT IS Y. C A,B,C ARRAYS WHICH CONTAIN THE TRIDIAGONAL MATRIX. C M THE ORDER OF THE MATRIX. C D,U,W WORKING ARRAYS. C IS DETERMINES WHETHER OR NOT A CHANGE IN SIGN IS MADE. C DIMENSION A(*) ,B(*) ,C(*) ,X(*) , 1 Y(*) ,D(*) ,U(*) ,BD(*) , 2 BM1(*) ,BM2(*) ,AA(*) ,W(*) C DO 10 J=1,M Y(J) = X(J) W(J) = Y(J) 10 CONTINUE MM = M-1 MM2 = M-2 ID = ND IBR = 0 M1 = NM1 M2 = NM2 IA = NA 20 IF (IA) 50, 50, 30 30 RT = AA(IA) IF (ND .EQ. 0) RT = -RT IA = IA-1 DO 40 J=1,M Y(J) = RT*W(J) 40 CONTINUE 50 IF (ID) 280,280, 60 60 RT = BD(ID) ID = ID-1 IF (ID .EQ. 0) IBR = 1 C C BEGIN SOLUTION TO SYSTEM C BH = B(M)-RT YM = Y(M) DEN = B(1)-RT D(1) = C(1)/DEN U(1) = A(1)/DEN W(1) = Y(1)/DEN V = C(M) IF (MM2-2) 90, 70, 70 70 DO 80 J=2,MM2 DEN = B(J)-RT-A(J)*D(J-1) D(J) = C(J)/DEN U(J) = -A(J)*U(J-1)/DEN W(J) = (Y(J)-A(J)*W(J-1))/DEN BH = BH-V*U(J-1) YM = YM-V*W(J-1) V = -V*D(J-1) 80 CONTINUE 90 DEN = B(M-1)-RT-A(M-1)*D(M-2) D(M-1) = (C(M-1)-A(M-1)*U(M-2))/DEN W(M-1) = (Y(M-1)-A(M-1)*W(M-2))/DEN AM = A(M)-V*D(M-2) BH = BH-V*U(M-2) YM = YM-V*W(M-2) DEN = BH-AM*D(M-1) IF (DEN) 100,110,100 100 W(M) = (YM-AM*W(M-1))/DEN GO TO 120 110 W(M) = 1. 120 W(M-1) = W(M-1)-D(M-1)*W(M) DO 130 J=2,MM K = M-J W(K) = W(K)-D(K)*W(K+1)-U(K)*W(M) 130 CONTINUE IF (NA) 160,160, 20 140 DO 150 J=1,M Y(J) = W(J) 150 CONTINUE IBR = 1 GO TO 20 160 IF (M1) 170,170,180 170 IF (M2) 140,140,230 180 IF (M2) 200,200,190 190 IF (ABS(BM1(M1))-ABS(BM2(M2))) 230,230,200 200 IF (IBR) 210,210,220 210 IF (ABS(BM1(M1)-BD(ID))-ABS(BM1(M1)-RT)) 140,220,220 220 RT = RT-BM1(M1) M1 = M1-1 GO TO 260 230 IF (IBR) 240,240,250 240 IF (ABS(BM2(M2)-BD(ID))-ABS(BM2(M2)-RT)) 140,250,250 250 RT = RT-BM2(M2) M2 = M2-1 260 DO 270 J=1,M Y(J) = Y(J)+RT*W(J) 270 CONTINUE GO TO 20 280 RETURN END SUBROUTINE CPROD0(ND,BD,NM1,BM1,NM2,BM2,NA,AA,X,YY,M,A,B,C,D,W,Y) C C CPROD0 APPLIES A SEQUENCE OF MATRIX OPERATIONS TO THE VECTOR X AND C STORES THE RESULT IN YY. (COMPLEX CASE) C C AA ARRAY CONTAINING SCALAR MULTIPLIERS OF THE VECTOR X. C ND,NM1,NM2 THE LENGTHS OF THE ARRAYS BD,BM1,BM2 RESPECTIVELY. C BD,BM1,BM2 ARRAYS CONTAINING ROOTS OF CERTIAN B POLYNOMIALS. C NA THE LENGTH OF THE ARRAY AA. C X,YY MATRIX OPERATIONS ARE APPLIED TO X AND THE RESULT IS YY. C A,B,C ARRAYS WHICH CONTAIN THE TRIDIAGONAL MATRIX. C M THE ORDER OF THE MATRIX. C D,W,Y WORKING ARRAYS. C ISGN DETERMINES WHETHER OR NOT A CHANGE IN SIGN IS MADE. C COMPLEX Y ,D ,W ,BD , 1 CRT ,DEN ,Y1 ,Y2 DIMENSION A(*) ,B(*) ,C(*) ,X(*) , 1 Y(*) ,D(*) ,W(*) ,BD(*) , 2 BM1(*) ,BM2(*) ,AA(*) ,YY(*) C DO 10 J=1,M Y(J) = CMPLX(X(J),0.) 10 CONTINUE MM = M-1 ID = ND M1 = NM1 M2 = NM2 IA = NA 20 IFLG = 0 IF (ID) 90, 90, 30 30 CRT = BD(ID) ID = ID-1 C C BEGIN SOLUTION TO SYSTEM C D(M) = A(M)/(B(M)-CRT) W(M) = Y(M)/(B(M)-CRT) DO 40 J=2,MM K = M-J DEN = B(K+1)-CRT-C(K+1)*D(K+2) D(K+1) = A(K+1)/DEN W(K+1) = (Y(K+1)-C(K+1)*W(K+2))/DEN 40 CONTINUE DEN = B(1)-CRT-C(1)*D(2) IF (CABS(DEN)) 50, 60, 50 50 Y(1) = (Y(1)-C(1)*W(2))/DEN GO TO 70 60 Y(1) = (1.,0.) 70 DO 80 J=2,M Y(J) = W(J)-D(J)*Y(J-1) 80 CONTINUE 90 IF (M1) 100,100,120 100 IF (M2) 210,210,110 110 RT = BM2(M2) M2 = M2-1 GO TO 170 120 IF (M2) 130,130,140 130 RT = BM1(M1) M1 = M1-1 GO TO 170 140 IF (ABS(BM1(M1))-ABS(BM2(M2))) 160,160,150 150 RT = BM1(M1) M1 = M1-1 GO TO 170 160 RT = BM2(M2) M2 = M2-1 170 Y1 = (B(1)-RT)*Y(1)+C(1)*Y(2) IF (MM-2) 200,180,180 C C MATRIX MULTIPLICATION C 180 DO 190 J=2,MM Y2 = A(J)*Y(J-1)+(B(J)-RT)*Y(J)+C(J)*Y(J+1) Y(J-1) = Y1 Y1 = Y2 190 CONTINUE 200 Y(M) = A(M)*Y(M-1)+(B(M)-RT)*Y(M) Y(M-1) = Y1 IFLG = 1 GO TO 20 210 IF (IA) 240,240,220 220 RT = AA(IA) IA = IA-1 IFLG = 1 C C SCALAR MULTIPLICATION C DO 230 J=1,M Y(J) = RT*Y(J) 230 CONTINUE 240 IF (IFLG) 250,250, 20 250 DO 260 J=1,M YY(J) = REAL(Y(J)) 260 CONTINUE RETURN END SUBROUTINE CPRODP (ND,BD,NM1,BM1,NM2,BM2,NA,AA,X,YY,M,A,B,C,D,U,Y) C C PRODP APPLIES A SEQUENCE OF MATRIX OPERATIONS TO THE VECTOR X AND C STORES THE RESULT IN YY. (PERIODIC BOUNDARY CONDITIONS AND C COMPLEX CASE) C C BD,BM1,BM2 ARRAYS CONTAINING ROOTS OF CERTIAN B POLYNOMIALS. C ND,NM1,NM2 THE LENGTHS OF THE ARRAYS BD,BM1,BM2 RESPECTIVELY. C AA ARRAY CONTAINING SCALAR MULTIPLIERS OF THE VECTOR X. C NA THE LENGTH OF THE ARRAY AA. C X,YY MATRIX OPERATIONS ARE APPLIED TO X AND THE RESULT IS YY. C A,B,C ARRAYS WHICH CONTAIN THE TRIDIAGONAL MATRIX. C M THE ORDER OF THE MATRIX. C D,U,Y WORKING ARRAYS. C ISGN DETERMINES WHETHER OR NOT A CHANGE IN SIGN IS MADE. C COMPLEX Y ,D ,U ,V , 1 DEN ,BH ,YM ,AM , 2 Y1 ,Y2 ,YH ,BD , 3 CRT DIMENSION A(*) ,B(*) ,C(*) ,X(*) , 1 Y(*) ,D(*) ,U(*) ,BD(*) , 2 BM1(*) ,BM2(*) ,AA(*) ,YY(*) C DO 10 J=1,M Y(J) = CMPLX(X(J),0.) 10 CONTINUE MM = M-1 MM2 = M-2 ID = ND M1 = NM1 M2 = NM2 IA = NA 20 IFLG = 0 IF (ID) 110,110, 30 30 CRT = BD(ID) ID = ID-1 IFLG = 1 C C BEGIN SOLUTION TO SYSTEM C BH = B(M)-CRT YM = Y(M) DEN = B(1)-CRT D(1) = C(1)/DEN U(1) = A(1)/DEN Y(1) = Y(1)/DEN V = CMPLX(C(M),0.) IF (MM2-2) 60, 40, 40 40 DO 50 J=2,MM2 DEN = B(J)-CRT-A(J)*D(J-1) D(J) = C(J)/DEN U(J) = -A(J)*U(J-1)/DEN Y(J) = (Y(J)-A(J)*Y(J-1))/DEN BH = BH-V*U(J-1) YM = YM-V*Y(J-1) V = -V*D(J-1) 50 CONTINUE 60 DEN = B(M-1)-CRT-A(M-1)*D(M-2) D(M-1) = (C(M-1)-A(M-1)*U(M-2))/DEN Y(M-1) = (Y(M-1)-A(M-1)*Y(M-2))/DEN AM = A(M)-V*D(M-2) BH = BH-V*U(M-2) YM = YM-V*Y(M-2) DEN = BH-AM*D(M-1) IF (CABS(DEN)) 70, 80, 70 70 Y(M) = (YM-AM*Y(M-1))/DEN GO TO 90 80 Y(M) = (1.,0.) 90 Y(M-1) = Y(M-1)-D(M-1)*Y(M) DO 100 J=2,MM K = M-J Y(K) = Y(K)-D(K)*Y(K+1)-U(K)*Y(M) 100 CONTINUE 110 IF (M1) 120,120,140 120 IF (M2) 230,230,130 130 RT = BM2(M2) M2 = M2-1 GO TO 190 140 IF (M2) 150,150,160 150 RT = BM1(M1) M1 = M1-1 GO TO 190 160 IF (ABS(BM1(M1))-ABS(BM2(M2))) 180,180,170 170 RT = BM1(M1) M1 = M1-1 GO TO 190 180 RT = BM2(M2) M2 = M2-1 C C MATRIX MULTIPLICATION C 190 YH = Y(1) Y1 = (B(1)-RT)*Y(1)+C(1)*Y(2)+A(1)*Y(M) IF (MM-2) 220,200,200 200 DO 210 J=2,MM Y2 = A(J)*Y(J-1)+(B(J)-RT)*Y(J)+C(J)*Y(J+1) Y(J-1) = Y1 Y1 = Y2 210 CONTINUE 220 Y(M) = A(M)*Y(M-1)+(B(M)-RT)*Y(M)+C(M)*YH Y(M-1) = Y1 IFLG = 1 GO TO 20 230 IF (IA) 260,260,240 240 RT = AA(IA) IA = IA-1 IFLG = 1 C C SCALAR MULTIPLICATION C DO 250 J=1,M Y(J) = RT*Y(J) 250 CONTINUE 260 IF (IFLG) 270,270, 20 270 DO 280 J=1,M YY(J) = REAL(Y(J)) 280 CONTINUE RETURN END SUBROUTINE COMPB (N,IERROR,AN,BN,CN,B,AH,BH) C C COMPB COMPUTES THE ROOTS OF THE B POLYNOMIALS USING TQLRT0, C WHICH IS A MODIFICATION OF THE EISPACK SUBROUTINE TQLRAT. C IERROR IS SET TO 4 IF EITHER TQLRT0 FAILS OR A(J+1)*C(J) IS C LESS THAN 0 FOR SOME J. AH AND BH ARE TEMPORARY WORK ARRAYS. C DIMENSION AN(*) ,BN(*) ,CN(*) ,B(*) , 1 AH(*) ,BH(*) COMMON /CBLKT/ NPP ,K ,EPS ,CNV , 1 NM ,NCMPLX ,IK C EPS = SPMPAR(1) BNORM = ABS(BN(1)) DO 40 J=2,NM BNORM = AMAX1(BNORM,ABS(BN(J))) ARG = AN(J)*CN(J-1) IF (ARG) 220, 30, 30 30 B(J) = SIGN(SQRT(ARG),AN(J)) 40 CONTINUE CNV = EPS*BNORM IF = 2**K KDO = K-1 DO 100 L=1,KDO IR = L-1 I2 = 2**IR I4 = I2+I2 IPL = I4-1 IFD = IF-I4 DO 90 I=I4,IFD,I4 CALL INDXB (I,L,IB,NB) IF (NB) 100,100, 50 50 JS = I-IPL JF = JS+NB-1 LS = 0 DO 60 J=JS,JF LS = LS+1 BH(LS) = BN(J) AH(LS) = B(J) 60 CONTINUE CALL TQLRT0 (NB,BH,AH,IERROR) IF (IERROR) 210, 70,210 70 LH = IB-1 DO 80 J=1,NB LH = LH+1 B(LH) = -BH(J) 80 CONTINUE 90 CONTINUE 100 CONTINUE DO 110 J=1,NM B(J) = -BN(J) 110 CONTINUE IF (NPP .NE. 0) RETURN C NMP = NM+1 NB = NM+NMP DO 150 J=1,NB L1 = MOD(J-1,NMP)+1 L2 = MOD(J+NM-1,NMP)+1 ARG = AN(L1)*CN(L2) IF (ARG .LT. 0.0) GO TO 220 BH(J) = SIGN(SQRT(ARG),-AN(L1)) AH(J) = -BN(L1) 150 CONTINUE CALL TQLRT0 (NB,AH,BH,IERROR) IF (IERROR .NE. 0) GO TO 210 C CALL INDXB (IF,K-1,J2,LH) CALL INDXB (IF/2,K-1,J1,LH) J2 = J2+1 LH = J2 N2M2 = J2+NM+NM-2 170 D1 = ABS(B(J1)-B(J2-1)) D2 = ABS(B(J1)-B(J2)) D3 = ABS(B(J1)-B(J2+1)) IF ((D2 .LT. D1) .AND. (D2 .LT. D3)) GO TO 180 B(LH) = B(J2) J2 = J2+1 LH = LH+1 IF (J2-N2M2) 170,170,190 180 J2 = J2+1 J1 = J1+1 IF (J2-N2M2) 170,170,190 190 B(LH) = B(N2M2+1) CALL INDXB (IF,K-1,J1,J2) J2 = J1+NMP+NMP CALL PPADD (NM+1,IERROR,AN,CN,B(J1),B(J1),B(J2)) RETURN C C ERROR RETURN C 210 IERROR = 4 RETURN 220 IERROR = 5 RETURN END SUBROUTINE TQLRT0 (N,D,E2,IERR) C INTEGER I ,J ,L ,M , 1 N ,II ,L1 ,MML , 2 IERR REAL D(N) ,E2(N) REAL B ,C ,F ,G , 1 H ,P ,R ,S , 2 MACHEP C COMMON /CBLKT/ NPP ,K ,MACHEP ,CNV , 1 NM ,NCMPLX ,IK C C C THIS SUBROUTINE IS A MODIFICATION OF THE EISPACK SUBROUTINE C TQLRAT. THE SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC C TRIDIAGONAL MATRIX BY THE RATIONAL QL METHOD. C C ON INPUT- C C N IS THE ORDER OF THE MATRIX, C C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX, C C E2 CONTAINS THE SUBDIAGONAL ELEMENTS OF THE C INPUT MATRIX IN ITS LAST N-1 POSITIONS. E2(1) IS ARBITRARY. C C ON OUTPUT- C C D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND C ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE C THE SMALLEST EIGENVALUES, C C E2 HAS BEEN DESTROYED, C C IERR IS SET TO C ZERO FOR NORMAL RETURN, C J IF THE J-TH EIGENVALUE HAS NOT BEEN C DETERMINED AFTER 30 ITERATIONS. C C C ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING C THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC. C C ********** C IERR = 0 IF (N .EQ. 1) GO TO 150 C DO 10 I=2,N E2(I-1) = E2(I)*E2(I) 10 CONTINUE C F = 0.0 B = 0.0 E2(N) = 0.0 C DO 120 L=1,N J = 0 H = MACHEP*(ABS(D(L))+SQRT(E2(L))) IF (B .GT. H) GO TO 20 B = H C = B*B C C ********** LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT ********** C 20 DO 30 M=L,N IF (E2(M) .LE. C) GO TO 40 C C ********** E2(N) IS ALWAYS ZERO, SO THERE IS NO EXIT C THROUGH THE BOTTOM OF THE LOOP ********** C 30 CONTINUE C 40 IF (M .EQ. L) GO TO 80 50 IF (J .EQ. 30) GO TO 140 J = J+1 C C ********** FORM SHIFT ********** C L1 = L+1 S = SQRT(E2(L)) G = D(L) P = (D(L1)-G)/(2.0*S) R = SQRT(P*P+1.0) D(L) = S/(P+SIGN(R,P)) H = G-D(L) C DO 60 I=L1,N D(I) = D(I)-H 60 CONTINUE C F = F+H C C ********** RATIONAL QL TRANSFORMATION ********** C G = D(M) IF (G .EQ. 0.0) G = B H = G S = 0.0 MML = M-L C C ********** FOR I=M-1 STEP -1 UNTIL L DO -- ********** C DO 70 II=1,MML I = M-II P = G*H R = P+E2(I) E2(I+1) = S*R S = E2(I)/R D(I+1) = H+S*(H+D(I)) G = D(I)-E2(I)/G IF (G .EQ. 0.0) G = B H = G*P/R 70 CONTINUE C E2(L) = S*G D(L) = H C C ********** GUARD AGAINST UNDERFLOWED H ********** C IF (H .EQ. 0.0) GO TO 80 IF (ABS(E2(L)) .LE. ABS(C/H)) GO TO 80 E2(L) = H*E2(L) IF (E2(L) .NE. 0.0) GO TO 50 80 P = D(L)+F C C ********** ORDER EIGENVALUES ********** C IF (L .EQ. 1) GO TO 100 C C ********** FOR I=L STEP -1 UNTIL 2 DO -- ********** C DO 90 II=2,L I = L+2-II IF (P .GE. D(I-1)) GO TO 110 D(I) = D(I-1) 90 CONTINUE C 100 I = 1 110 D(I) = P 120 CONTINUE C IF (ABS(D(N)) .GE. ABS(D(1))) GO TO 150 NHALF = N/2 DO 130 I=1,NHALF NTOP = N-I DHOLD = D(I) D(I) = D(NTOP+1) D(NTOP+1) = DHOLD 130 CONTINUE GO TO 150 C C ********** SET ERROR -- NO CONVERGENCE TO AN C EIGENVALUE AFTER 30 ITERATIONS ********** C 140 IERR = L 150 RETURN END SUBROUTINE PPADD (N,IERROR,A,C,CBP,BP,BH) C C PPADD COMPUTES THE EIGENVALUES OF THE PERIODIC TRIDIAGONAL MATRIX C WITH COEFFICIENTS AN,BN,CN C C N IS THE ORDER OF THE BH AND BP POLYNOMIALS. C ON OUTPUT BP CONTAINS THE EIGENVALUES. C CBP IS THE SAME AS BP EXCEPT TYPE COMPLEX. C BH IS USED TO TEMPORARILY STORE THE ROOTS OF THE B HAT POLYNOMIAL C WHICH ENTERS THROUGH BP. C COMPLEX CF ,CX ,FSG ,HSG , 1 DD ,F ,FP ,FPP , 2 CDIS ,R1 ,R2 ,R3 , 3 CBP DIMENSION A(*) ,C(*) ,BP(*) ,BH(*) , 1 CBP(*) EXTERNAL PSGF ,PPSPF ,PPSGF COMMON /CBLKT/ NPP ,K ,EPS ,CNV , 1 NM ,NCMPLX ,IK C SCNV = SQRT(CNV) IZ = N IZM = IZ-1 IZM2 = IZ-2 IF (BP(N)-BP(1)) 10,420, 30 10 DO 20 J=1,N NT = N-J BH(J) = BP(NT+1) 20 CONTINUE GO TO 50 30 DO 40 J=1,N BH(J) = BP(J) 40 CONTINUE 50 NCMPLX = 0 MODIZ = MOD(IZ,2) IS = 1 IF (MODIZ) 60, 70, 60 60 IF (A(1)) 100,420, 70 70 XL = BH(1) DB = BH(3)-BH(1) 80 XL = XL-DB IF (PSGF(XL,IZ,C,A,BH)) 80, 80, 90 90 SGN = -1. CBP(1) = CMPLX(BSRH(XL,BH(1),IZ,C,A,BH,PSGF,SGN),0.) IS = 2 100 IF = IZ-1 IF (MODIZ) 110,120,110 110 IF (A(1)) 120,420,150 120 XR = BH(IZ) DB = BH(IZ)-BH(IZ-2) 130 XR = XR+DB IF (PSGF(XR,IZ,C,A,BH)) 130,140,140 140 SGN = 1. CBP(IZ) = CMPLX(BSRH(BH(IZ),XR,IZ,C,A,BH,PSGF,SGN),0.) IF = IZ-2 150 DO 360 IG=IS,IF,2 XL = BH(IG) XR = BH(IG+1) SGN = -1. XM = BSRH(XL,XR,IZ,C,A,BH,PPSPF,SGN) PSG = PSGF(XM,IZ,C,A,BH) IF (ABS(PSG)-EPS) 180,180,160 160 IF (PSG*PPSGF(XM,IZ,C,A,BH)) 170,180,190 C C CASE OF A REAL ZERO C 170 SGN = 1. CBP(IG) = CMPLX(BSRH(BH(IG),XM,IZ,C,A,BH,PSGF,SGN),0.) SGN = -1. CBP(IG+1) = CMPLX(BSRH(XM,BH(IG+1),IZ,C,A,BH,PSGF,SGN),0.) GO TO 360 C C CASE OF A MULTIPLE ZERO C 180 CBP(IG) = CMPLX(XM,0.) CBP(IG+1) = CMPLX(XM,0.) GO TO 360 C C CASE OF A COMPLEX ZERO C 190 IT = 0 ICV = 0 CX = CMPLX(XM,0.) 200 FSG = (1.,0.) HSG = (1.,0.) FP = (0.,0.) FPP = (0.,0.) DO 210 J=1,IZ DD = 1./(CX-BH(J)) FSG = FSG*A(J)*DD HSG = HSG*C(J)*DD FP = FP+DD FPP = FPP-DD*DD 210 CONTINUE IF (MODIZ) 230,220,230 220 F = (1.,0.)-FSG-HSG GO TO 240 230 F = (1.,0.)+FSG+HSG 240 I3 = 0 IF (CABS(FP)) 260,260,250 250 I3 = 1 R3 = -F/FP 260 I2 = 0 IF (CABS(FPP)) 320,320,270 270 I2 = 1 CDIS = CSQRT(FP**2-2.*F*FPP) R1 = CDIS-FP R2 = -FP-CDIS IF (CABS(R1)-CABS(R2)) 290,290,280 280 R1 = R1/FPP GO TO 300 290 R1 = R2/FPP 300 R2 = 2.*F/FPP/R1 IF (CABS(R2) .LT. CABS(R1)) R1 = R2 IF (I3) 330,330,310 310 IF (CABS(R3) .LT. CABS(R1)) R1 = R3 GO TO 330 320 R1 = R3 330 CX = CX+R1 IT = IT+1 IF (IT .GT. 50) GO TO 420 IF (CABS(R1) .GT. SCNV) GO TO 200 IF (ICV) 340,340,350 340 ICV = 1 GO TO 200 350 CBP(IG) = CX CBP(IG+1) = CONJG(CX) 360 CONTINUE IF (CABS(CBP(N))-CABS(CBP(1))) 370,420,390 370 NHALF = N/2 DO 380 J=1,NHALF NT = N-J CX = CBP(J) CBP(J) = CBP(NT+1) CBP(NT+1) = CX 380 CONTINUE 390 NCMPLX = 1 DO 400 J=2,IZ IF (AIMAG(CBP(J))) 430,400,430 400 CONTINUE NCMPLX = 0 DO 410 J=2,IZ BP(J) = REAL(CBP(J)) 410 CONTINUE GO TO 430 420 IERROR = 4 430 CONTINUE RETURN END FUNCTION PSGF (X,IZ,C,A,BH) DIMENSION A(*) ,C(*) ,BH(*) FSG = 1. HSG = 1. DO 10 J=1,IZ DD = 1./(X-BH(J)) FSG = FSG*A(J)*DD HSG = HSG*C(J)*DD 10 CONTINUE IF (MOD(IZ,2)) 30, 20, 30 20 PSGF = 1.-FSG-HSG RETURN 30 PSGF = 1.+FSG+HSG RETURN END FUNCTION BSRH (XLL,XRR,IZ,C,A,BH,F,SGN) DIMENSION A(*) ,C(*) ,BH(*) COMMON /CBLKT/ NPP ,K ,EPS ,CNV , 1 NM ,NCMPLX ,IK XL = XLL XR = XRR DX = .5*ABS(XR-XL) 10 X = .5*(XL+XR) IF (SGN*F(X,IZ,C,A,BH)) 30, 50, 20 20 XR = X GO TO 40 30 XL = X 40 DX = .5*DX IF (DX-CNV) 50, 50, 10 50 BSRH = .5*(XL+XR) RETURN END FUNCTION PPSGF (X,IZ,C,A,BH) DIMENSION A(*) ,C(*) ,BH(*) SUM = 0. DO 10 J=1,IZ SUM = SUM-1./(X-BH(J))**2 10 CONTINUE PPSGF = SUM RETURN END FUNCTION PPSPF (X,IZ,C,A,BH) DIMENSION A(*) ,C(*) ,BH(*) SUM = 0. DO 10 J=1,IZ SUM = SUM+1./(X-BH(J)) 10 CONTINUE PPSPF = SUM RETURN END SUBROUTINE URGET (N, IBEG, IEND, IX, L, IERR) C----------------------------------------------------------------------- C C UNIFORM RANDOM SELECTION OF VALUES FROM C A FINITE SET OF INTEGERS C C ---------------- C C URGET SELECTS N VALUES FROM THE SET OF INTEGERS FROM IBEG TO C IEND WHERE IBEG .LT. IEND. THE SELECTION IS PERFORMED SO THAT C ANY INTEGER IS EQUALLY LIKELY TO OCCUR WITH PROABILITY 1/M C WHERE M = IEND - IBEG + 1. AS N BECOMES LARGE THE MEAN AND C VARIANCE OF THE VALUES WILL CLOSELY APPROXIMATE THE MEAN AND C VARIANCE OF THE DISCRETE UNIFORM DISTRIBUTION WHERE C C MEAN = IBEG + (IEND - IBEG)/2 C C VARIANCE = (M**2 - 1)/12 . C C INPUT... C C N - NUMBER OF VARIATES TO BE GENERATED C IBEG - LOWER LIMIT OF GENERATION INTERVAL C IEND - UPPER LIMIT OF GENERATION INTERVAL C IX - INTEGER SEED USED TO INITIALIZE THE C SEQUENCE OF VARIATES GENERATED C C OUTPUT... C C IX - SEED FOR OBTAINING MORE VARIATES C L - OUTPUT ARRAY OF DIMENSION N CONTAINING C THE GENERATED INTEGERS C IERR - INPUT ERROR FLAG C ( 0 - NO INPUT ERRORS C 1 - N .LE. 0 C 2 - IBEG .GE. IEND OR M .GE. P. C 3 - SEED OUT OF RANGE ) C C----------------------------------------------------------------------- INTEGER L(N) INTEGER A, B15, B16, FHI, P, XALO, XHI DOUBLE PRECISION C, M, S, T C------------------- C DATA A/7**5/, B15/2**15/, B16/2**16/, P/2**31 - 1/ C S = 1/(P-1) (IT IS ASSUMED THAT THE ARITHMETIC BEING C USED IS ACCURATE TO AT LEAST 14 DIGITS. C S HAS BEEN SET TO A VALUE SLIGHTLY LESS C THAN 1/(P-1) TO ENSURE THAT ROUNDING C ERROR DOES NOT PRODUCE VARIATES THAT C EXCEED IEND.) C------------------- DATA A/16807/, B15/32768/, B16/65536/, P/2147483647/ DATA S /.4656612877413D-09/ C------------------- IF (N .LE. 0) GO TO 100 IF (IBEG .GE. IEND) GO TO 110 IF (IX .LE. 0 .OR. IX .GE. P) GO TO 120 M = IEND - IBEG + 1 T = P IF (M .GE. T) GO TO 110 C IERR = 0 C = M*S DO 10 I = 1,N C C USE THE LINUS SCHRAGE CODE TO OBTAIN THE NEXT SEED IX. C C REFERENCE. SCHRAGE, LINUS, A MORE PORTABLE FORTRAN C RANDOM NUMBER GENERATOR, ACM TRANS. MATH SOFTWARE 5 C (1979), PP. 132-138. C XHI = IX/B16 XALO = (IX - XHI*B16)*A LEFTLO = XALO/B16 FHI = XHI*A + LEFTLO K = FHI/B15 IX = (((XALO - LEFTLO*B16) - P) + (FHI - K*B15)*B16) + K IF (IX .LT. 0) IX = IX + P C C MAP IX TO AN INTEGER IN THE CLOSED INTERVAL (IBEG,IEND). C THIS MAPPING IS 1-1 ONLY WHEN M = P - 1, IN WHICH CASE C IX IS MAPPED TO THE VALUE (IBEG - 1) + IX. C T = IX K = C*T L(I) = IBEG + K 10 CONTINUE RETURN C C ERROR RETURN C 100 IERR = 1 RETURN 110 IERR = 2 RETURN 120 IERR = 3 RETURN END SUBROUTINE URNG (IX, X, N, IERR) REAL X(N) C----------------------------------------------------------------------- C UNIFORM RANDOM NUMBER GENERATOR USING THE RECURSION C C IX = IX*A MOD P C C IT IS ASSUMED THAT 0 .LT. IX .LT. P C----------------------------------------------------------------------- C WRITTEN BY C LINUS SCHRAGE C UNIVERSITY OF CHICAGO C ADAPTED BY A.H. MORRIS (NSWC) C------------------- INTEGER A, B15, B16, FHI, P, XALO, XHI C------------------- C DATA A/7**5/, B15/2**15/, B16/2**16/, P/2**31 - 1/ C------------------- DATA A/16807/, B15/32768/, B16/65536/, P/2147483647/ DATA S/.465661E-09/ C------------------- IF (N .LE. 0) GO TO 100 IF (IX .LE. 0 .OR. IX .GE. P) GO TO 110 IERR = 0 DO 10 L = 1,N C C GET 15 HIGH ORDER BITS OF IX C XHI = IX/B16 C C GET 16 LOWER BITS OF IX AND MULTIPLY WITH A C XALO = (IX - XHI*B16)*A C C GET 15 HIGH ORDER BITS OF THE PRODUCT C LEFTLO = XALO/B16 C C FORM THE 31 HIGHEST BITS OF A*IX C FHI = XHI*A + LEFTLO C C OBTAIN THE OVERFLOW PAST THE 31ST BIT OF A*IX C K = FHI/B15 C C ASSEMBLE ALL THE PARTS AND PRESUBTRACT P C THE PARENTHESES ARE ESSENTIAL C IX = (((XALO - LEFTLO*B16) - P) + (FHI - K*B15)*B16) + K C C ADD P IF NECESSARY C IF (IX .LT. 0) IX = IX + P C C RESCALE IX, TO INTERPRET IT AS A VALUE BETWEEN 0 AND 1. C THE SCALE FACTOR S IS SELECTED TO BE AS NEAR 1/P AS IS C APPROPRIATE IN ORDER THAT THE FLOATING VALUE FOR IX = 1, C NAMELY S, BE ROUGHLY THE SAME DISTANCE FROM 0 AS (P-1)*S C IS FROM 1. THE CURRENT VALUE FOR S ASSURES US THAT X(L) C IS LESS THAN 1 FOR ANY FLOATING POINT ARITHMETIC OF 6 C OR MORE DIGITS. C T = IX X(L) = S*T 10 CONTINUE RETURN C C ERROR RETURN C 100 IERR = 1 RETURN 110 IERR = 2 RETURN END SUBROUTINE DURNG (IX, X, N, IERR) DOUBLE PRECISION X(N) C----------------------------------------------------------------------- C UNIFORM RANDOM NUMBER GENERATOR USING THE RECURSION C C IX = IX*A MOD P C C IT IS ASSUMED THAT 0 .LT. IX .LT. P C----------------------------------------------------------------------- C WRITTEN BY C LINUS SCHRAGE C UNIVERSITY OF CHICAGO C ADAPTED BY A.H. MORRIS (NSWC) C------------------- INTEGER A, B15, B16, FHI, P, XALO, XHI DOUBLE PRECISION S, T C------------------- C DATA A/7**5/, B15/2**15/, B16/2**16/, P/2**31 - 1/ C------------------- DATA A/16807/, B15/32768/, B16/65536/, P/2147483647/ DATA S/.465661D-09/ C------------------- IF (N .LE. 0) GO TO 100 IF (IX .LE. 0 .OR. IX .GE. P) GO TO 110 IERR = 0 DO 10 L = 1,N C C GET 15 HIGH ORDER BITS OF IX C XHI = IX/B16 C C GET 16 LOWER BITS OF IX AND MULTIPLY WITH A C XALO = (IX - XHI*B16)*A C C GET 15 HIGH ORDER BITS OF THE PRODUCT C LEFTLO = XALO/B16 C C FORM THE 31 HIGHEST BITS OF A*IX C FHI = XHI*A + LEFTLO C C OBTAIN THE OVERFLOW PAST THE 31ST BIT OF A*IX C K = FHI/B15 C C ASSEMBLE ALL THE PARTS AND PRESUBTRACT P C THE PARENTHESES ARE ESSENTIAL C IX = (((XALO - LEFTLO*B16) - P) + (FHI - K*B15)*B16) + K C C ADD P IF NECESSARY C IF (IX .LT. 0) IX = IX + P C C RESCALE IX, TO INTERPRET IT AS A VALUE BETWEEN 0 AND 1. C THE SCALE FACTOR S IS SELECTED TO BE AS NEAR 1/P AS IS C APPROPRIATE IN ORDER THAT THE FLOATING VALUE FOR IX = 1, C NAMELY S, BE ROUGHLY THE SAME DISTANCE FROM 0 AS (P-1)*S C IS FROM 1. THE CURRENT VALUE FOR S ASSURES US THAT X(L) C IS LESS THAN 1 FOR ANY DOUBLE PRECISION ARITHMETIC. C T = IX X(L) = S*T 10 CONTINUE RETURN C C ERROR RETURN C 100 IERR = 1 RETURN 110 IERR = 2 RETURN END SUBROUTINE URNG0 (IX, U, V) C----------------------------------------------------------------------- C UNIFORM RANDOM NUMBER GENERATOR USING THE RECURSION C C IX = IX*A MOD P C C U IS THE UNIFORM VARIATE THAT IS GENERATED AND V = 1 - U. C U AND V ARE POSITIVE. IT IS ASSUMED THAT 1 .LE. IX .LT. P. C----------------------------------------------------------------------- C WRITTEN BY C LINUS SCHRAGE C UNIVERSITY OF CHICAGO C ADAPTED BY A.H. MORRIS (NSWC) C------------------- INTEGER A, B15, B16, FHI, P, P0, XALO, XHI C------------------- C DATA A/7**5/, B15/2**15/, B16/2**16/, P/2**31 - 1/ C DATA P0/2**30 - 1/ C------------------- DATA A/16807/, B15/32768/, B16/65536/, P/2147483647/ DATA P0/1073741823/ C------------------- C C GET 15 HIGH ORDER BITS OF IX C XHI = IX/B16 C C GET 16 LOWER BITS OF IX AND MULTIPLY WITH A C XALO = (IX - XHI*B16)*A C C GET 15 HIGH ORDER BITS OF THE PRODUCT C LEFTLO = XALO/B16 C C FORM THE 31 HIGHEST BITS OF A*IX C FHI = XHI*A + LEFTLO C C OBTAIN THE OVERFLOW PAST THE 31ST BIT OF A*IX C K = FHI/B15 C C ASSEMBLE ALL THE PARTS AND PRESUBTRACT P C THE PARENTHESES ARE ESSENTIAL C IX = (((XALO - LEFTLO*B16) - P) + (FHI - K*B15)*B16) + K C C ADD P IF NECESSARY C IF (IX .LT. 0) IX = IX + P C C RESCALE IX, TO INTERPRET IT AS A VALUE BETWEEN 0 AND 1 C T = P IF (IX .GT. P0) GO TO 10 U = IX U = U/T V = 0.5 + (0.5 - U) RETURN 10 V = P - IX V = V/T U = 0.5 + (0.5 - V) RETURN END SUBROUTINE DURNG0 (IX, U, V) C----------------------------------------------------------------------- C UNIFORM RANDOM NUMBER GENERATOR USING THE RECURSION C C IX = IX*A MOD P C C U IS THE UNIFORM VARIATE THAT IS GENERATED AND V = 1 - U. C U AND V ARE POSITIVE. IT IS ASSUMED THAT 1 .LE. IX .LT. P. C----------------------------------------------------------------------- C WRITTEN BY C LINUS SCHRAGE C UNIVERSITY OF CHICAGO C ADAPTED BY A.H. MORRIS (NSWC) C------------------- DOUBLE PRECISION U, V, T INTEGER A, B15, B16, FHI, P, P0, XALO, XHI C------------------- C DATA A/7**5/, B15/2**15/, B16/2**16/, P/2**31 - 1/ C DATA P0/2**30 - 1/ C------------------- DATA A/16807/, B15/32768/, B16/65536/, P/2147483647/ DATA P0/1073741823/ C------------------- C C GET 15 HIGH ORDER BITS OF IX C XHI = IX/B16 C C GET 16 LOWER BITS OF IX AND MULTIPLY WITH A C XALO = (IX - XHI*B16)*A C C GET 15 HIGH ORDER BITS OF THE PRODUCT C LEFTLO = XALO/B16 C C FORM THE 31 HIGHEST BITS OF A*IX C FHI = XHI*A + LEFTLO C C OBTAIN THE OVERFLOW PAST THE 31ST BIT OF A*IX C K = FHI/B15 C C ASSEMBLE ALL THE PARTS AND PRESUBTRACT P C THE PARENTHESES ARE ESSENTIAL C IX = (((XALO - LEFTLO*B16) - P) + (FHI - K*B15)*B16) + K C C ADD P IF NECESSARY C IF (IX .LT. 0) IX = IX + P C C RESCALE IX, TO INTERPRET IT AS A VALUE BETWEEN 0 AND 1 C T = P IF (IX .GT. P0) GO TO 10 U = IX U = U/T V = 0.5D0 + (0.5D0 - U) RETURN 10 V = P - IX V = V/T U = 0.5D0 + (0.5D0 - V) RETURN END SUBROUTINE URNG1 (IX, U, V, D) C----------------------------------------------------------------------- C UNIFORM RANDOM NUMBER GENERATOR USING THE RECURSION C C IX = IX*A MOD P C C U IS THE UNIFORM VARIATE THAT IS GENERATED AND V = 1 - U. C U AND V ARE POSITIVE AND D = U - 0.5. IT IS ASSUMED THAT C 1 .LE. IX .LT. P. C----------------------------------------------------------------------- C WRITTEN BY C LINUS SCHRAGE C UNIVERSITY OF CHICAGO C ADAPTED BY A.H. MORRIS (NSWC) C------------------- INTEGER A, B15, B16, FHI, P, P0, XALO, XHI C------------------- C DATA A/7**5/, B15/2**15/, B16/2**16/, P/2**31 - 1/ C DATA P0/2**30 - 1/ C------------------- DATA A/16807/, B15/32768/, B16/65536/, P/2147483647/ DATA P0/1073741823/ C------------------- C C GET 15 HIGH ORDER BITS OF IX C XHI = IX/B16 C C GET 16 LOWER BITS OF IX AND MULTIPLY WITH A C XALO = (IX - XHI*B16)*A C C GET 15 HIGH ORDER BITS OF THE PRODUCT C LEFTLO = XALO/B16 C C FORM THE 31 HIGHEST BITS OF A*IX C FHI = XHI*A + LEFTLO C C OBTAIN THE OVERFLOW PAST THE 31ST BIT OF A*IX C K = FHI/B15 C C ASSEMBLE ALL THE PARTS AND PRESUBTRACT P C THE PARENTHESES ARE ESSENTIAL C IX = (((XALO - LEFTLO*B16) - P) + (FHI - K*B15)*B16) + K C C ADD P IF NECESSARY C IF (IX .LT. 0) IX = IX + P C C RESCALE IX, TO INTERPRET IT AS A VALUE BETWEEN 0 AND 1 C J = P - IX T = P D = IX - J D = 0.5*(D/T) IF (IX .GT. P0) GO TO 10 U = IX U = U/T V = 0.5 + (0.5 - U) RETURN 10 V = J V = V/T U = 0.5 + (0.5 - V) RETURN END SUBROUTINE DURNG1 (IX, U, V, D) C----------------------------------------------------------------------- C UNIFORM RANDOM NUMBER GENERATOR USING THE RECURSION C C IX = IX*A MOD P C C U IS THE UNIFORM VARIATE THAT IS GENERATED AND V = 1 - U. C U AND V ARE POSITIVE AND D = U - 0.5. IT IS ASSUMED THAT C 1 .LE. IX .LT. P. C----------------------------------------------------------------------- C WRITTEN BY C LINUS SCHRAGE C UNIVERSITY OF CHICAGO C ADAPTED BY A.H. MORRIS (NSWC) C------------------- DOUBLE PRECISION U, V, D, T INTEGER A, B15, B16, FHI, P, P0, XALO, XHI C------------------- C DATA A/7**5/, B15/2**15/, B16/2**16/, P/2**31 - 1/ C DATA P0/2**30 - 1/ C------------------- DATA A/16807/, B15/32768/, B16/65536/, P/2147483647/ DATA P0/1073741823/ C------------------- C C GET 15 HIGH ORDER BITS OF IX C XHI = IX/B16 C C GET 16 LOWER BITS OF IX AND MULTIPLY WITH A C XALO = (IX - XHI*B16)*A C C GET 15 HIGH ORDER BITS OF THE PRODUCT C LEFTLO = XALO/B16 C C FORM THE 31 HIGHEST BITS OF A*IX C FHI = XHI*A + LEFTLO C C OBTAIN THE OVERFLOW PAST THE 31ST BIT OF A*IX C K = FHI/B15 C C ASSEMBLE ALL THE PARTS AND PRESUBTRACT P C THE PARENTHESES ARE ESSENTIAL C IX = (((XALO - LEFTLO*B16) - P) + (FHI - K*B15)*B16) + K C C ADD P IF NECESSARY C IF (IX .LT. 0) IX = IX + P C C RESCALE IX, TO INTERPRET IT AS A VALUE BETWEEN 0 AND 1 C J = P - IX T = P D = IX - J D = 0.5D0*(D/T) IF (IX .GT. P0) GO TO 10 U = IX U = U/T V = 0.5D0 + (0.5D0 - U) RETURN 10 V = J V = V/T U = 0.5D0 + (0.5D0 - V) RETURN END SUBROUTINE URNG2 (IX, X, Y, N, IERR) C----------------------------------------------------------------------- C C GENERATION OF UNIFORM RANDOM POINTS (X(I),Y(I)) C FOR I = 1,...,N WHERE C C 0 .LT. X(I) .LT. 1 C 0 .LT. Y(I) .LT. 1 C C IT IS ASSUMED THAT 0 .LT. IX .LT. P C----------------------------------------------------------------------- C WRITTEN BY C LINUS SCHRAGE C UNIVERSITY OF CHICAGO C ADAPTED BY A.H. MORRIS (NSWC) C------------------- REAL X(N), Y(N) INTEGER A, B15, B16, FHI, P, XALO, XHI C------------------- C DATA A/7**5/, B15/2**15/, B16/2**16/, P/2**31 - 1/ C------------------- DATA A/16807/, B15/32768/, B16/65536/, P/2147483647/ DATA S/.465661E-09/ C------------------- IF (N .LE. 0) GO TO 100 IF (IX .LE. 0 .OR. IX .GE. P) GO TO 110 IERR = 0 C C SEE THE COMMENTS IN THE SUBROUTINE URNG FOR THE C STATEMENTS IN THE FOLLOWING LOOP C DO 10 L = 1,N XHI = IX/B16 XALO = (IX - XHI*B16)*A LEFTLO = XALO/B16 FHI = XHI*A + LEFTLO K = FHI/B15 IX = (((XALO - LEFTLO*B16) - P) + (FHI - K*B15)*B16) + K IF (IX .LT. 0) IX = IX + P T = IX X(L) = S*T C XHI = IX/B16 XALO = (IX - XHI*B16)*A LEFTLO = XALO/B16 FHI = XHI*A + LEFTLO K = FHI/B15 IX = (((XALO - LEFTLO*B16) - P) + (FHI - K*B15)*B16) + K IF (IX .LT. 0) IX = IX + P T = IX Y(L) = S*T 10 CONTINUE RETURN C C ERROR RETURN C 100 IERR = 1 RETURN 110 IERR = 2 RETURN END SUBROUTINE DURNG2 (IX, X, Y, N, IERR) C----------------------------------------------------------------------- C C GENERATION OF UNIFORM RANDOM POINTS (X(I),Y(I)) C FOR I = 1,...,N WHERE C C 0 .LT. X(I) .LT. 1 C 0 .LT. Y(I) .LT. 1 C C IT IS ASSUMED THAT 0 .LT. IX .LT. P C----------------------------------------------------------------------- C WRITTEN BY C LINUS SCHRAGE C UNIVERSITY OF CHICAGO C ADAPTED BY A.H. MORRIS (NSWC) C------------------- DOUBLE PRECISION X(N), Y(N) DOUBLE PRECISION S, T INTEGER A, B15, B16, FHI, P, XALO, XHI C------------------- C DATA A/7**5/, B15/2**15/, B16/2**16/, P/2**31 - 1/ C------------------- DATA A/16807/, B15/32768/, B16/65536/, P/2147483647/ DATA S/.465661D-09/ C------------------- IF (N .LE. 0) GO TO 100 IF (IX .LE. 0 .OR. IX .GE. P) GO TO 110 IERR = 0 C C SEE THE COMMENTS IN THE SUBROUTINE DURNG FOR THE C STATEMENTS IN THE FOLLOWING LOOP C DO 10 L = 1,N XHI = IX/B16 XALO = (IX - XHI*B16)*A LEFTLO = XALO/B16 FHI = XHI*A + LEFTLO K = FHI/B15 IX = (((XALO - LEFTLO*B16) - P) + (FHI - K*B15)*B16) + K IF (IX .LT. 0) IX = IX + P T = IX X(L) = S*T C XHI = IX/B16 XALO = (IX - XHI*B16)*A LEFTLO = XALO/B16 FHI = XHI*A + LEFTLO K = FHI/B15 IX = (((XALO - LEFTLO*B16) - P) + (FHI - K*B15)*B16) + K IF (IX .LT. 0) IX = IX + P T = IX Y(L) = S*T 10 CONTINUE RETURN C C ERROR RETURN C 100 IERR = 1 RETURN 110 IERR = 2 RETURN END SUBROUTINE RCIR (N, IX, X, Y, IERR) C----------------------------------------------------------------------- C C GENERATION OF N UNIFORM RANDOM POINTS (X(I),Y(I)) C IN THE UNIT CIRCLE CENTERED AT THE ORIGIN C C----------------------------------------------------------------------- REAL X(N), Y(N) C------------------ CALL RCIR1 (N, IX, X, 1, Y, 1, IERR) RETURN END SUBROUTINE RCIR1 (N, IX, X, KX, Y, KY, IERR) C----------------------------------------------------------------------- C C GENERATION OF N UNIFORM RANDOM POINTS IN THE UNIT CIRCLE C CENTERED AT THE ORIGIN. THE ABSCISSA AND ORDINATE OF THE C I-TH POINT ARE STORED IN X(I1) AND Y(I2) WHERE C C I1 = 1 + KX*(I - 1) C I2 = 1 + KY*(I - 1) . C C----------------------------------------------------------------------- REAL X(*), Y(*) INTEGER A, B15, B16, FHI, P, P0, XALO, XHI C------------------- C DATA A/7**5/, B15/2**15/, B16/2**16/, P/2**31 - 1/ C P0 = 2**30 - 1 C S = 2/P C------------------- DATA A/16807/, B15/32768/, B16/65536/, P/2147483647/ DATA P0/1073741823/ DATA S/.931322E-09/ C------------------- IF (N .LE. 0) GO TO 100 IF (IX .LE. 0 .OR. IX .GE. P) GO TO 110 IERR = 0 C I1 = 1 I2 = 1 DO 20 I = 1,N C C USE THE LINUS SCHRAGE CODE TO OBTAIN NEW SEEDS IX. C C REFERENCE. SCHRAGE, LINUS, A MORE PORTABLE FORTRAN C RANDOM NUMBER GENERATOR, ACM TRANS. MATH SOFTWARE 5 C (1979), PP. 132-138. C 10 XHI = IX/B16 XALO = (IX - XHI*B16)*A LEFTLO = XALO/B16 FHI = XHI*A + LEFTLO K = FHI/B15 IX = (((XALO - LEFTLO*B16) - P) + (FHI - K*B15)*B16) + K IF (IX .LT. 0) IX = IX + P J = IX C XHI = IX/B16 XALO = (IX - XHI*B16)*A LEFTLO = XALO/B16 FHI = XHI*A + LEFTLO K = FHI/B15 IX = (((XALO - LEFTLO*B16) - P) + (FHI - K*B15)*B16) + K IF (IX .LT. 0) IX = IX + P C C SUBTRACT THE MIDPOINT P0 AND RESCALE SO THAT THE C UNIFORM VARIATES ARE IN THE INTERVAL (-1,1). C U = J - P0 U = S*U V = IX - P0 V = S*V C C CHECK IF THE POINT (U,V) IS IN THE UNIT CIRCLE C R = (U*U + V*V) - 1.0 IF (R .GE. 0.0) GO TO 10 C C STORE THE POINT WHEN IT IS IN THE CIRCLE C X(I1) = U Y(I2) = V I1 = I1 + KX I2 = I2 + KY 20 CONTINUE RETURN C C ERROR RETURN C 100 IERR = 1 RETURN 110 IERR = 2 RETURN END SUBROUTINE DRCIR (N, IX, X, Y, IERR) C----------------------------------------------------------------------- C C GENERATION OF N UNIFORM RANDOM POINTS (X(I),Y(I)) C IN THE UNIT CIRCLE CENTERED AT THE ORIGIN C C----------------------------------------------------------------------- DOUBLE PRECISION X(N), Y(N) C------------------ CALL DRCIR1 (N, IX, X, 1, Y, 1, IERR) RETURN END SUBROUTINE DRCIR1 (N, IX, X, KX, Y, KY, IERR) C----------------------------------------------------------------------- C C GENERATION OF N UNIFORM RANDOM POINTS IN THE UNIT CIRCLE C CENTERED AT THE ORIGIN. THE ABSCISSA AND ORDINATE OF THE C I-TH POINT ARE STORED IN X(I1) AND Y(I2) WHERE C C I1 = 1 + KX*(I - 1) C I2 = 1 + KY*(I - 1) . C C----------------------------------------------------------------------- DOUBLE PRECISION X(*), Y(*) DOUBLE PRECISION R, S, U, V INTEGER A, B15, B16, FHI, P, P0, XALO, XHI C------------------- C DATA A/7**5/, B15/2**15/, B16/2**16/, P/2**31 - 1/ C P0 = 2**30 - 1 C S = 2/P C------------------- DATA A/16807/, B15/32768/, B16/65536/, P/2147483647/ DATA P0/1073741823/ DATA S/.931322D-09/ C------------------- IF (N .LE. 0) GO TO 100 IF (IX .LE. 0 .OR. IX .GE. P) GO TO 110 IERR = 0 C I1 = 1 I2 = 1 DO 20 I = 1,N C C USE THE LINUS SCHRAGE CODE TO OBTAIN NEW SEEDS IX. C C REFERENCE. SCHRAGE, LINUS, A MORE PORTABLE FORTRAN C RANDOM NUMBER GENERATOR, ACM TRANS. MATH SOFTWARE 5 C (1979), PP. 132-138. C 10 XHI = IX/B16 XALO = (IX - XHI*B16)*A LEFTLO = XALO/B16 FHI = XHI*A + LEFTLO K = FHI/B15 IX = (((XALO - LEFTLO*B16) - P) + (FHI - K*B15)*B16) + K IF (IX .LT. 0) IX = IX + P J = IX C XHI = IX/B16 XALO = (IX - XHI*B16)*A LEFTLO = XALO/B16 FHI = XHI*A + LEFTLO K = FHI/B15 IX = (((XALO - LEFTLO*B16) - P) + (FHI - K*B15)*B16) + K IF (IX .LT. 0) IX = IX + P C C SUBTRACT THE MIDPOINT P0 AND RESCALE SO THAT THE C UNIFORM VARIATES ARE IN THE INTERVAL (-1,1). C U = J - P0 U = S*U V = IX - P0 V = S*V C C CHECK IF THE POINT (U,V) IS IN THE UNIT CIRCLE C R = (U*U + V*V) - 1.D0 IF (R .GE. 0.D0) GO TO 10 C C STORE THE POINT WHEN IT IS IN THE CIRCLE C X(I1) = U Y(I2) = V I1 = I1 + KX I2 = I2 + KY 20 CONTINUE RETURN C C ERROR RETURN C 100 IERR = 1 RETURN 110 IERR = 2 RETURN END SUBROUTINE RNOR (IX, A, N, IERR) C----------------------------------------------------------------------- C NORMAL RANDOM NUMBER GENERATOR C----------------------------------------------------------------------- REAL A(N), T(2) C--------------------- DATA MAX /2147483647/ C--------------------- IF (N .LE. 0) GO TO 100 IF (IX .LE. 0 .OR. IX .GE. MAX) GO TO 110 IERR = 0 C IF (N .EQ. 1) GO TO 20 M = N/2 CALL RCIR1 (M, IX, A(1), 2, A(2), 2, IERR) M = M + M C C OBTAIN THE FIRST M VARIATES C DO 10 I = 1,M,2 U = A(I) V = A(I + 1) R = U*U + V*V S = SQRT(-2.0*ALOG(R)/R) A(I) = S*U A(I + 1) = S*V 10 CONTINUE IF (M .EQ. N) RETURN C C OBTAIN THE LAST VARIATE (WHEN N IS ODD) C 20 CALL RCIR1 (1, IX, T(1), 1, T(2), 1, IERR) R = T(1)*T(1) + T(2)*T(2) S = SQRT(-2.0*ALOG(R)/R) A(N) = S*T(1) RETURN C C ERROR RETURN C 100 IERR = 1 RETURN 110 IERR = 2 RETURN END SUBROUTINE DRNOR (IX, A, N, IERR) C----------------------------------------------------------------------- C NORMAL RANDOM NUMBER GENERATOR C----------------------------------------------------------------------- DOUBLE PRECISION A(N) DOUBLE PRECISION R, S, U, V, T(2) C--------------------- DATA MAX /2147483647/ C--------------------- IF (N .LE. 0) GO TO 100 IF (IX .LE. 0 .OR. IX .GE. MAX) GO TO 110 IERR = 0 C IF (N .EQ. 1) GO TO 20 M = N/2 CALL DRCIR1 (M, IX, A(1), 2, A(2), 2, IERR) M = M + M C C OBTAIN THE FIRST M VARIATES C DO 10 I = 1,M,2 U = A(I) V = A(I + 1) R = U*U + V*V S = DSQRT(-2.D0*DLOG(R)/R) A(I) = S*U A(I + 1) = S*V 10 CONTINUE IF (M .EQ. N) RETURN C C OBTAIN THE LAST VARIATE (WHEN N IS ODD) C 20 CALL DRCIR1 (1, IX, T(1), 1, T(2), 1, IERR) R = T(1)*T(1) + T(2)*T(2) S = DSQRT(-2.D0*DLOG(R)/R) A(N) = S*T(1) RETURN C C ERROR RETURN C 100 IERR = 1 RETURN 110 IERR = 2 RETURN END SUBROUTINE NRNG (IX, A, N, IERR) C----------------------------------------------------------------------- C GAUSSIAN RANDOM NUMBER GENERATOR C----------------------------------------------------------------------- REAL A(N), TEMP(1) DATA PI2 /6.2831853071796/ C CALL URNG (IX,A,N,IERR) IF (IERR .NE. 0) RETURN IF (N .EQ. 1) GO TO 20 C M = N/2 M = M + M DO 10 I = 1,M,2 R = SQRT(-2.0*ALOG(A(I))) PHI = PI2*A(I+1) A(I) = R*COS(PHI) 10 A(I+1) = R*SIN(PHI) IF (M .EQ. N) RETURN C 20 CALL URNG (IX,TEMP,1,IERR) R = SQRT(-2.0*ALOG(A(N))) A(N) = R*COS(PI2*TEMP(1)) RETURN END SUBROUTINE DNRNG (IX, A, N, IERR) C----------------------------------------------------------------------- C GAUSSIAN RANDOM NUMBER GENERATOR C----------------------------------------------------------------------- DOUBLE PRECISION A(N) DOUBLE PRECISION PHI, PI2, R, TEMP(1) C DATA PI2 /6.28318530717958647692528676656D0/ C CALL DURNG (IX, A, N, IERR) IF (IERR .NE. 0) RETURN IF (N .EQ. 1) GO TO 20 C M = N/2 M = M + M DO 10 I = 1,M,2 R = DSQRT(-2.D0*DLOG(A(I))) PHI = PI2*A(I+1) A(I) = R*DCOS(PHI) 10 A(I+1) = R*DSIN(PHI) IF (M .EQ. N) RETURN C 20 CALL DURNG (IX, TEMP, 1, IERR) R = DSQRT(-2.D0*DLOG(A(N))) A(N) = R*DCOS(PI2*TEMP(1)) RETURN END SUBROUTINE NRVG (MO, IX, N, M, A, FMU, X, KX, IERR) C----------------------------------------------------------------------- C C GENERATION OF N RANDOM NORMAL VECTORS OF LENGTH M C FROM A MULTIVARIATE NORMAL DISTRIBUTION WITH MEAN C VECTOR FMU AND VARIANCE-COVARIANCE MATRIX A. C C --------------- C C INPUT... C C MO - INTEGER SPECIFYING IF THE ROUTINE IS C BEING CALLED FOR THE FIRST TIME TO C GENERATE NORMAL VECTORS FROM A MATRIX C A. SET MO = 0 ON AN INITIAL CALL TO C THE ROUTINE, AND MO .NE. 0 ON A LATER C CALL TO GENERATE MORE VECTORS FROM C THE SAME MATRIX A. C C IX - INTEGER SEED USED TO INITIALIZE THE C SEQUENCE OF VARIATES. C C N - NUMBER OF RANDOM VECTORS TO BE GENERATED. C C M - LENGTH OF THE DESIRED RANDOM VECTORS. C IT IS ASSUMED THAT M .GE. 2. M SHOULD C NOT BE MODIFIED BY THE USER ON A LATER C CALL TO THE ROUTINE (WHEN MO .NE. 0). C C A - VARIANCE-COVARIANCE MATRIX OF ORDER M. C A IS A SYMMETRIC POSITIVE DEFINITE MATRIX C STORED IN PACKED FORM. THE ARRAY A MUST C BE OF LENGTH (M*(M + 1))/2 OR LARGER. C C ON AN INITIAL CALL TO THE ROUTINE, THE C LOWER TRIANGULAR MATRIX IN THE CHOLESKY C DECOMPOSITION OF A REPLACES THE ORIGINAL C DATA IN THE ARRAY A. A SHOULD NEVER BE C MODIFIED BY THE USER ON A LATER CALL TO C THE ROUTINE (WHEN MO .NE. 0). C C FMU - MEAN VECTOR OF DIMENSION M OF THE C MULTIVARIATE NORMAL DISTRIBUTION C C KX - ROW DIMENSION OF THE MATRIX X (SEE THE C DESCRIPTION OF X BELOW). IT IS ASSUMED C THAT KX .GE. M. C C OUTPUT... C C IX - SEED TO BE USED FOR OBTAINING MORE VARIATES. C C X - OUTPUT ARRAY OF DIMENSION KX BY N CONTAINING C THE N GENERATED RANDOM NORMAL VECTORS. THE C J-TH VECTOR IS STORED IN THE J-TH COLUMN OF C X FOR J = 1,...,N. C C IERR - INPUT ERROR FLAG C (0 - NO INPUT ERRORS C 1 - N .LE. 0 C 2 - M .LE. 1 OR M .GT. KX C 3 - A IS NOT POSITIVE DEFINITE C 4 - SEED OUT OF RANGE ) C C----------------------------------------------------------------------- C C ***REFERENCES*** C C FISHMAN, GEORGE S., CONCEPTS AND METHODS IN DISCRETE EVENT C DIGITAL SIMULATION, JOHN WILEY AND SONS, NEW YORK, 1973, C PP. 215 - 217. C C MORRISON, DONALD F., MULTIVARIATE STATISTICAL METHODS, C MCGRAW-HILL, NEW YORK, 1967, PP. 80 - 81. C C SCHEUER, E. AND STOLLER, D. S., ON THE GENERATION OF C NORMAL RANDOM VECTORS, TECHNOMETRICS, VOLUME 4, MAY, 1962, C PP. 278 - 281. C C----------------------------------------------------------------------- REAL A(*), FMU(M), X(KX,N) C-------------------- DATA MAX /2147483647/ C-------------------- IF (N .LE. 0) GO TO 100 IF (M .LE. 1 .OR. M .GT. KX) GO TO 110 IF (IX .LE. 0 .OR. IX .GE. MAX) GO TO 130 C C COMPUTE THE LOWER TRIANGULAR MATRIX C L HAVING POSITIVE DIAGONAL ELEMENTS C AND SATISFYING A = L*TRANSPOSE(L). C IF (MO .NE. 0) GO TO 10 CALL SPPFA (A, M, IERR) IF (IERR .NE. 0) GO TO 120 C C GENERATE THE N RANDOM NORMAL VECTORS C 10 LDIM = (M*(M + 1))/2 DO 40 J = 1,N CALL RNOR (IX, X(1,J), M, IERR) C C OBTAIN THE COMPONENTS OF THE J-TH VECTOR C IN REVERSE ORDER C L0 = LDIM I = M DO 30 II = 1,M L0 = L0 - I L = L0 SUM = 0.0 DO 20 K = 1,I L = L + 1 20 SUM = SUM + A(L)*X(K,J) X(I,J) = SUM + FMU(I) I = I - 1 30 CONTINUE 40 CONTINUE RETURN C C ERROR RETURN C 100 IERR = 1 RETURN 110 IERR = 2 RETURN 120 IERR = 3 RETURN 130 IERR = 4 RETURN END SUBROUTINE NRVG1 (MO, IX, N, M, A, FMU, X, KX, IERR) C----------------------------------------------------------------------- C C GENERATION OF N RANDOM NORMAL VECTORS OF LENGTH M C FROM A MULTIVARIATE NORMAL DISTRIBUTION WITH MEAN C VECTOR FMU AND VARIANCE-COVARIANCE MATRIX A. IT IS C ASSUMED THAT A IS A DIAGONAL MATRIX. C C --------------- C C INPUT... C C MO - INTEGER SPECIFYING IF THE ROUTINE IS C BEING CALLED FOR THE FIRST TIME TO C GENERATE NORMAL VECTORS FROM A MATRIX C A. SET MO = 0 ON AN INITIAL CALL TO C THE ROUTINE, AND MO .NE. 0 ON A LATER C CALL TO GENERATE MORE VECTORS FROM C THE SAME MATRIX A. C C IX - INTEGER SEED USED TO INITIALIZE THE C SEQUENCE OF VARIATES. C C N - NUMBER OF RANDOM VECTORS TO BE GENERATED. C C M - LENGTH OF THE DESIRED RANDOM VECTORS. C IT IS ASSUMED THAT M .GE. 2. M SHOULD C NOT BE MODIFIED BY THE USER ON A LATER C CALL TO THE ROUTINE (WHEN MO .NE. 0). C C A - VARIANCE-COVARIANCE MATRIX OF ORDER M. C A IS A DIAGONAL MATRIX WITH POSITIVE C DIAGONAL ELEMENTS. THE DIAGONAL ELEMENTS C ARE STORED IN THE ARRAY A. A IS AN ARRAY C OF LENGTH M OR LARGER. C C ON AN INITIAL CALL TO THE ROUTINE, THE C SQUARE ROOTS OF THE ELEMENTS OF A REPLACE C THE ORIGINAL DATA IN A. A SHOULD NOT BE C MODIFIED BY THE USER ON A LATER CALL TO C THE ROUTINE (WHEN MO .NE. 0). C C FMU - MEAN VECTOR OF DIMENSION M OF THE C MULTIVARIATE NORMAL DISTRIBUTION C C KX - ROW DIMENSION OF THE MATRIX X (SEE THE C DESCRIPTION OF X BELOW). IT IS ASSUMED C THAT KX .GE. M. C C OUTPUT... C C IX - SEED TO BE USED FOR OBTAINING MORE VARIATES. C C X - OUTPUT ARRAY OF DIMENSION KX BY N CONTAINING C THE N GENERATED RANDOM NORMAL VECTORS. THE C J-TH VECTOR IS STORED IN THE J-TH COLUMN OF C X FOR J = 1,...,N. C C IERR - INPUT ERROR FLAG C (0 - NO INPUT ERRORS C 1 - N .LE. 0 C 2 - M .LE. 1 OR M .GT. KX C 3 - A(I) .LE. 0 FOR SOME I C 4 - SEED OUT OF RANGE ) C C----------------------------------------------------------------------- REAL A(M), FMU(M), X(KX,N) C-------------------- DATA MAX /2147483647/ C-------------------- IF (N .LE. 0) GO TO 100 IF (M .LE. 1 .OR. M .GT. KX) GO TO 110 IF (IX .LE. 0 .OR. IX .GE. MAX) GO TO 130 C C COMPUTE THE ROOTS OF THE DIAGONAL ELEMENTS C IF (MO .NE. 0) GO TO 20 DO 10 I = 1,M IF (A(I) .LE. 0.0) GO TO 120 A(I) = SQRT(A(I)) 10 CONTINUE C C GENERATE THE N RANDOM NORMAL VECTORS C 20 DO 40 J = 1,N CALL RNOR (IX, X(1,J), M, IERR) DO 30 I = 1,M X(I,J) = A(I)*X(I,J) + FMU(I) 30 CONTINUE 40 CONTINUE RETURN C C ERROR RETURN C 100 IERR = 1 RETURN 110 IERR = 2 RETURN 120 IERR = 3 RETURN 130 IERR = 4 RETURN END SUBROUTINE DNRVG (MO, IX, N, M, A, FMU, X, KX, IERR) C----------------------------------------------------------------------- C C GENERATION OF N RANDOM NORMAL VECTORS OF LENGTH M C FROM A MULTIVARIATE NORMAL DISTRIBUTION WITH MEAN C VECTOR FMU AND VARIANCE-COVARIANCE MATRIX A. C C --------------- C C INPUT... C C MO - INTEGER SPECIFYING IF THE ROUTINE IS C BEING CALLED FOR THE FIRST TIME TO C GENERATE NORMAL VECTORS FROM A MATRIX C A. SET MO = 0 ON AN INITIAL CALL TO C THE ROUTINE, AND MO .NE. 0 ON A LATER C CALL TO GENERATE MORE VECTORS FROM C THE SAME MATRIX A. C C IX - INTEGER SEED USED TO INITIALIZE THE C SEQUENCE OF VARIATES. C C N - NUMBER OF RANDOM VECTORS TO BE GENERATED. C C M - LENGTH OF THE DESIRED RANDOM VECTORS. C IT IS ASSUMED THAT M .GE. 2. M SHOULD C NOT BE MODIFIED BY THE USER ON A LATER C CALL TO THE ROUTINE (WHEN MO .NE. 0). C C A - VARIANCE-COVARIANCE MATRIX OF ORDER M. C A IS A SYMMETRIC POSITIVE DEFINITE MATRIX C STORED IN PACKED FORM. THE ARRAY A MUST C BE OF LENGTH (M*(M + 1))/2 OR LARGER. C C ON AN INITIAL CALL TO THE ROUTINE, THE C LOWER TRIANGULAR MATRIX IN THE CHOLESKY C DECOMPOSITION OF A REPLACES THE ORIGINAL C DATA IN THE ARRAY A. A SHOULD NEVER BE C MODIFIED BY THE USER ON A LATER CALL TO C THE ROUTINE (WHEN MO .NE. 0). C C FMU - MEAN VECTOR OF DIMENSION M OF THE C MULTIVARIATE NORMAL DISTRIBUTION C C KX - ROW DIMENSION OF THE MATRIX X (SEE THE C DESCRIPTION OF X BELOW). IT IS ASSUMED C THAT KX .GE. M. C C OUTPUT... C C IX - SEED TO BE USED FOR OBTAINING MORE VARIATES. C C X - OUTPUT ARRAY OF DIMENSION KX BY N CONTAINING C THE N GENERATED RANDOM NORMAL VECTORS. THE C J-TH VECTOR IS STORED IN THE J-TH COLUMN OF C X FOR J = 1,...,N. C C IERR - INPUT ERROR FLAG C (0 - NO INPUT ERRORS C 1 - N .LE. 0 C 2 - M .LE. 1 OR M .GT. KX C 3 - A IS NOT POSITIVE DEFINITE C 4 - SEED OUT OF RANGE ) C C----------------------------------------------------------------------- C C ***REFERENCES*** C C FISHMAN, GEORGE S., CONCEPTS AND METHODS IN DISCRETE EVENT C DIGITAL SIMULATION, JOHN WILEY AND SONS, NEW YORK, 1973, C PP. 215 - 217. C C MORRISON, DONALD F., MULTIVARIATE STATISTICAL METHODS, C MCGRAW-HILL, NEW YORK, 1967, PP. 80 - 81. C C SCHEUER, E. AND STOLLER, D. S., ON THE GENERATION OF C NORMAL RANDOM VECTORS, TECHNOMETRICS, VOLUME 4, MAY, 1962, C PP. 278 - 281. C C----------------------------------------------------------------------- DOUBLE PRECISION A(*), FMU(M), X(KX,N), SUM C-------------------- DATA MAX /2147483647/ C-------------------- IF (N .LE. 0) GO TO 100 IF (M .LE. 1 .OR. M .GT. KX) GO TO 110 IF (IX .LE. 0 .OR. IX .GE. MAX) GO TO 130 C C COMPUTE THE LOWER TRIANGULAR MATRIX C L HAVING POSITIVE DIAGONAL ELEMENTS C AND SATISFYING A = L*TRANSPOSE(L). C IF (MO .NE. 0) GO TO 10 CALL DPPFA (A, M, IERR) IF (IERR .NE. 0) GO TO 120 C C GENERATE THE N RANDOM NORMAL VECTORS C 10 LDIM = (M*(M + 1))/2 DO 40 J = 1,N CALL DRNOR (IX, X(1,J), M, IERR) C C OBTAIN THE COMPONENTS OF THE J-TH VECTOR C IN REVERSE ORDER C L0 = LDIM I = M DO 30 II = 1,M L0 = L0 - I L = L0 SUM = 0.D0 DO 20 K = 1,I L = L + 1 20 SUM = SUM + A(L)*X(K,J) X(I,J) = SUM + FMU(I) I = I - 1 30 CONTINUE 40 CONTINUE RETURN C C ERROR RETURN C 100 IERR = 1 RETURN 110 IERR = 2 RETURN 120 IERR = 3 RETURN 130 IERR = 4 RETURN END SUBROUTINE DNRVG1 (MO, IX, N, M, A, FMU, X, KX, IERR) C----------------------------------------------------------------------- C C GENERATION OF N RANDOM NORMAL VECTORS OF LENGTH M C FROM A MULTIVARIATE NORMAL DISTRIBUTION WITH MEAN C VECTOR FMU AND VARIANCE-COVARIANCE MATRIX A. IT IS C ASSUMED THAT A IS A DIAGONAL MATRIX. C C --------------- C C INPUT... C C MO - INTEGER SPECIFYING IF THE ROUTINE IS C BEING CALLED FOR THE FIRST TIME TO C GENERATE NORMAL VECTORS FROM A MATRIX C A. SET MO = 0 ON AN INITIAL CALL TO C THE ROUTINE, AND MO .NE. 0 ON A LATER C CALL TO GENERATE MORE VECTORS FROM C THE SAME MATRIX A. C C IX - INTEGER SEED USED TO INITIALIZE THE C SEQUENCE OF VARIATES. C C N - NUMBER OF RANDOM VECTORS TO BE GENERATED. C C M - LENGTH OF THE DESIRED RANDOM VECTORS. C IT IS ASSUMED THAT M .GE. 2. M SHOULD C NOT BE MODIFIED BY THE USER ON A LATER C CALL TO THE ROUTINE (WHEN MO .NE. 0). C C A - VARIANCE-COVARIANCE MATRIX OF ORDER M. C A IS A DIAGONAL MATRIX WITH POSITIVE C DIAGONAL ELEMENTS. THE DIAGONAL ELEMENTS C ARE STORED IN THE ARRAY A. A IS AN ARRAY C OF LENGTH M OR LARGER. C C ON AN INITIAL CALL TO THE ROUTINE, THE C SQUARE ROOTS OF THE ELEMENTS OF A REPLACE C THE ORIGINAL DATA IN A. A SHOULD NOT BE C MODIFIED BY THE USER ON A LATER CALL TO C THE ROUTINE (WHEN MO .NE. 0). C C FMU - MEAN VECTOR OF DIMENSION M OF THE C MULTIVARIATE NORMAL DISTRIBUTION C C KX - ROW DIMENSION OF THE MATRIX X (SEE THE C DESCRIPTION OF X BELOW). IT IS ASSUMED C THAT KX .GE. M. C C OUTPUT... C C IX - SEED TO BE USED FOR OBTAINING MORE VARIATES. C C X - OUTPUT ARRAY OF DIMENSION KX BY N CONTAINING C THE N GENERATED RANDOM NORMAL VECTORS. THE C J-TH VECTOR IS STORED IN THE J-TH COLUMN OF C X FOR J = 1,...,N. C C IERR - INPUT ERROR FLAG C (0 - NO INPUT ERRORS C 1 - N .LE. 0 C 2 - M .LE. 1 OR M .GT. KX C 3 - A(I) .LE. 0 FOR SOME I C 4 - SEED OUT OF RANGE ) C C----------------------------------------------------------------------- DOUBLE PRECISION A(M), FMU(M), X(KX,N) C-------------------- DATA MAX /2147483647/ C-------------------- IF (N .LE. 0) GO TO 100 IF (M .LE. 1 .OR. M .GT. KX) GO TO 110 IF (IX .LE. 0 .OR. IX .GE. MAX) GO TO 130 C C COMPUTE THE ROOTS OF THE DIAGONAL ELEMENTS C IF (MO .NE. 0) GO TO 20 DO 10 I = 1,M IF (A(I) .LE. 0.D0) GO TO 120 A(I) = DSQRT(A(I)) 10 CONTINUE C C GENERATE THE N RANDOM NORMAL VECTORS C 20 DO 40 J = 1,N CALL DRNOR (IX, X(1,J), M, IERR) DO 30 I = 1,M X(I,J) = A(I)*X(I,J) + FMU(I) 30 CONTINUE 40 CONTINUE RETURN C C ERROR RETURN C 100 IERR = 1 RETURN 110 IERR = 2 RETURN 120 IERR = 3 RETURN 130 IERR = 4 RETURN END SUBROUTINE RANEXP (N,A,ISEED,X,IERROR) C C ***SUBROUTINE PURPOSE AND DESCRIPTION*** C C RANEXP GENERATES N EXPONENTIAL RANDOM VARIATES FROM AN C EXPONENTIAL DISTRIBUTION WITH PARAMETER A (A .GT. 0). C A IS THE MEAN OF THE DISTRIBUTION. HENCE, A IS INTERPRETED C AS THE AVERAGE RATE PER UNIT OF TIME OR THE AVERAGE TIME C TO FAILURE (AVERAGE LIFETIME). C C FORM OF THE EXPONENTIAL PROBABILITY DENSITY FUNCTION... C C F(X) = (1/A) * EXP(-X/A) , X .GE. 0 C A .GT. 0 C C MEAN AND VARIANCE OF THE EXPONENTIAL DISTRIBUTION... C C MEAN = A C C VARIANCE = A**2 C C ***PARAMETER LIST*** C C INPUT... C C N - NUMBER OF VARIATES TO BE GENERATED C A - MEAN OF THE EXPONENTIAL DISTRIBUTION C ISEED - INTEGER SEED USED TO INITIALIZE THE C SEQUENCE OF VARIATES GENERATED C C OUTPUT... C C ISEED - SEED TO BE USED ON THE NEXT CALL TO THE C ROUTINE C X - OUTPUT ARRAY OF DIMENSION N CONTAINING C THE GENERATED REAL VARIATES C IERROR - INPUT ERROR FLAG C ( 0 - NO INPUT ERRORS C 1 - N .LE. 0 C 2 - A .LE. 0.0 C 3 - SEED OUT OF RANGE ) C C ***REFERENCE*** C C FISHMAN, GEORGE S., CONCEPTS AND METHODS IN DISCRETE EVENT C DIGITAL SIMULATION, JOHN WILEY AND SONS, NEW YORK, 1973, C P. 203. C REAL X(N) C C CHECK TO ENSURE THAT THE DESIRED NUMBER OF VARIATES IS WITHIN C ACCEPTABLE RANGE C IF (N .LE. 0) GO TO 100 C C CHECK TO ENSURE THAT THE EXPONENTIAL PARAMETER HAS BEEN C PROPERLY SPECIFIED C IF (A .LE. 0.0) GO TO 110 C C GENERATION OF UNIFORM RANDOM VARIATES C CALL URNG (ISEED, X, N, IERROR) IF (IERROR .NE. 0) GO TO 120 C C LOOP WHICH GENERATES THE N DESIRED VARIATES C DO 10 I=1,N X(I) = - A*ALOG(X(I)) 10 CONTINUE RETURN C C ERROR RETURN C 100 IERROR = 1 RETURN 110 IERROR = 2 RETURN 120 IERROR = 3 RETURN END SUBROUTINE DRNEXP (N,A,ISEED,X,IERROR) C C ***SUBROUTINE PURPOSE AND DESCRIPTION*** C C DRNEXP GENERATES N EXPONENTIAL RANDOM VARIATES FROM AN C EXPONENTIAL DISTRIBUTION WITH PARAMETER A (A .GT. 0). C A IS THE MEAN OF THE DISTRIBUTION. HENCE, A IS INTERPRETED C AS THE AVERAGE RATE PER UNIT OF TIME OR THE AVERAGE TIME C TO FAILURE (AVERAGE LIFETIME). C C FORM OF THE EXPONENTIAL PROBABILITY DENSITY FUNCTION... C C F(X) = (1/A) * EXP(-X/A) , X .GE. 0 C A .GT. 0 C C MEAN AND VARIANCE OF THE EXPONENTIAL DISTRIBUTION... C C MEAN = A C C VARIANCE = A**2 C C ***PARAMETER LIST*** C C INPUT... C C N - NUMBER OF VARIATES TO BE GENERATED C A - MEAN OF THE EXPONENTIAL DISTRIBUTION C ISEED - INTEGER SEED USED TO INITIALIZE THE C SEQUENCE OF VARIATES GENERATED C C OUTPUT... C C ISEED - SEED TO BE USED ON THE NEXT CALL TO THE C ROUTINE C X - OUTPUT ARRAY OF DIMENSION N CONTAINING C THE GENERATED REAL VARIATES C IERROR - INPUT ERROR FLAG C ( 0 - NO INPUT ERRORS C 1 - N .LE. 0 C 2 - A .LE. 0.0 C 3 - SEED OUT OF RANGE ) C C ***REFERENCE*** C C FISHMAN, GEORGE S., CONCEPTS AND METHODS IN DISCRETE EVENT C DIGITAL SIMULATION, JOHN WILEY AND SONS, NEW YORK, 1973, C P. 203. C DOUBLE PRECISION A, X(N) C C CHECK TO ENSURE THAT THE DESIRED NUMBER OF VARIATES IS WITHIN C ACCEPTABLE RANGE C IF (N .LE. 0) GO TO 100 C C CHECK TO ENSURE THAT THE EXPONENTIAL PARAMETER HAS BEEN C PROPERLY SPECIFIED C IF (A .LE. 0.D0) GO TO 110 C C GENERATION OF UNIFORM RANDOM VARIATES C CALL DURNG (ISEED, X, N, IERROR) IF (IERROR .NE. 0) GO TO 120 C C LOOP WHICH GENERATES THE N DESIRED VARIATES C DO 10 I=1,N X(I) = - A*DLOG(X(I)) 10 CONTINUE RETURN C C ERROR RETURN C 100 IERROR = 1 RETURN 110 IERROR = 2 RETURN 120 IERROR = 3 RETURN END SUBROUTINE RGAM (IX, A, N, X, IERR) C----------------------------------------------------------------------- C C COMPUTATION OF N VARIATES X(1),...,X(N) C FROM THE GAMMA DISTRIBUTION HAVING THE C PROBABILITY DENSITY FUNCTION C C F(T) = EXP(-T)*T**(A-1)/GAMMA(A) C C ------------------ C C IX IS A VARIABLE. ON INPUT IX IS A SEED FOR INITIALIZING THE C SEQUENCE OF VARIATES. ON OUTPUT IX IS A NEW SEED FOR OBTAINING C MORE VARIATES. IT IS ASSUMED THAT 1 .LE. IX .LT. 2**31 - 1. C C IERR IS A VARIABLE WHICH REPORTS THE STATUS OF THE RESULTS. C WHEN THE SUBROUTINE TERMINATES IERR HAS ONE OF THE FOLLOWING C VALUES ... C C IERR = 0 THE GAMMA VARIATES WERE OBTAINED. C IERR = 1 (INPUT ERROR) N .LE. 0 C IERR = 2 (INPUT ERROR) A .LT. 0.1 C IERR = 3 (INPUT ERROR) IX IS NOT A PROPER C SEED. C C----------------------------------------------------------------------- REAL X(N) C DATA MAX /2147483647/ C IF (N .LE. 0) GO TO 100 IF (A .LT. 0.1) GO TO 110 IF (IX .LT. 1 .OR. IX .GE. MAX) GO TO 120 IERR = 0 C C THE FOLLOWING CODE ASSUMES THAT THE UNIFORM C VARIATES ARE FAR ENOUGH FROM 0 AND 1 SO THAT C THE SETTING IND = -8 IS AVOIDED C DO 10 I = 1,N CALL URNG0 (IX, U, V) CALL GAMINV (A, W, 0.0, U, V, IND) IF (IND .EQ. -3 .OR. IND .EQ. -7) W = 0.0 X(I) = W 10 CONTINUE RETURN C C ERROR RETURN C 100 IERR = 1 RETURN 110 IERR = 2 RETURN 120 IERR = 3 RETURN END SUBROUTINE DRGAM (IX, A, N, X, IERR) C----------------------------------------------------------------------- C C COMPUTATION OF N DOUBLE PRECISION VARIATES C X(1),...,X(N) FROM THE GAMMA DISTRIBUTION C HAVING THE PROBABILITY DENSITY FUNCTION C C F(T) = EXP(-T)*T**(A-1)/GAMMA(A) C C ------------------ C C IX IS A VARIABLE. ON INPUT IX IS A SEED FOR INITIALIZING THE C SEQUENCE OF VARIATES. ON OUTPUT IX IS A NEW SEED FOR OBTAINING C MORE VARIATES. IT IS ASSUMED THAT 1 .LE. IX .LT. 2**31 - 1. C C IERR IS A VARIABLE WHICH REPORTS THE STATUS OF THE RESULTS. C WHEN THE SUBROUTINE TERMINATES IERR HAS ONE OF THE FOLLOWING C VALUES ... C C IERR = 0 THE GAMMA VARIATES WERE OBTAINED. C IERR = 1 (INPUT ERROR) N .LE. 0 C IERR = 2 (INPUT ERROR) A .LT. 0.1 C IERR = 3 (INPUT ERROR) IX IS NOT A PROPER C SEED. C C----------------------------------------------------------------------- DOUBLE PRECISION A, X(N) DOUBLE PRECISION U, V, W C DATA MAX /2147483647/ C IF (N .LE. 0) GO TO 100 IF (A .LT. 0.1D0) GO TO 110 IF (IX .LT. 1 .OR. IX .GE. MAX) GO TO 120 IERR = 0 C C THE FOLLOWING CODE ASSUMES THAT THE UNIFORM C VARIATES ARE FAR ENOUGH FROM 0 AND 1 SO THAT C THE SETTING IND = -8 IS AVOIDED C DO 10 I = 1,N CALL DURNG0 (IX, U, V) CALL DGINV (A, W, U, V, IND) IF (IND .EQ. -3 .OR. IND .EQ. -7) W = 0.D0 X(I) = W 10 CONTINUE RETURN C C ERROR RETURN C 100 IERR = 1 RETURN 110 IERR = 2 RETURN 120 IERR = 3 RETURN END SUBROUTINE RBETA (N, A, B, IX, X, IERR) C----------------------------------------------------------------------- C C GENERATION OF BETA RANDOM VARIATES C C ------------ C C RBETA GENERATES N VARIATES FROM THE BETA DISTRIBUTION WITH C PARAMETERS A AND B WHERE A .GE. 0.25 AND B .GE. 0.25. THE C GENERATION SCHEME IS BASED ON THE FACT THAT X1 / (X1 + X2) C IS A VARIATE FROM THE BETA DISTRIBUTION WHEN X1 AND X2 ARE C INDEPENDENT VARIATES FROM THE STANDARD GAMMA DISTRIBUTIONS C WITH PARAMETERS A AND B RESPECTIVELY. C C FORM OF THE BETA PROBABILITY DENSITY FUNCTION USED... C C F(X) = X**(A - 1) * (1 - X)**(B - 1) / BETA(A,B) C C WHERE 0 .LE. X .LE. 1 AND C BETA(A,B) IS THE BETA FUNCTION. C C MEAN AND VARIANCE OF THE BETA DISTRIBUTION... C C MEAN = A / (A + B) C C VARIANCE = (A * B) / ((A + B)**2 * (A + B + 1)) C C INPUT... C C N - NUMBER OF VARIATES TO BE GENERATED C A - PARAMETER OF THE BETA DISTRIBUTION C B - PARAMETER OF THE BETA DISTRIBUTION C IX - INTEGER SEED USED TO INITIALIZE THE C SEQUENCE OF VARIATES C C OUTPUT... C C IX - SEED TO BE USED FOR OBTAINING MORE C VARIATES C X - ARRAY OF DIMENSION N CONTAINING THE C BETA VARIATES C IERR - INPUT ERROR FLAG C (0 - NO INPUT ERRORS C 1 - N .LE. 0 C 2 - A OR B IS LESS THAN 0.25 C 3 - SEED OUT OF RANGE ) C C----------------------------------------------------------------------- REAL X(N) C-------------------- DATA MAX /2147483647/ C-------------------- IF (N .LE. 0) GO TO 100 IF (AMIN1(A,B) .LT. 0.25) GO TO 110 IF (IX .LE. 0 .OR. IX .GE. MAX) GO TO 120 IERR = 0 C DO 10 I = 1,N C C THE FOLLOWING CODE ASSUMES THAT THE UNIFORM C VARIATES ARE FAR ENOUGH FROM 0 AND 1 SO THAT C THE SETTING IND = -8 IN GAMINV IS AVOIDED. C CALL URNG0 (IX, U, V) CALL GAMINV (A, X1, 0.0, U, V, IND) IF (IND .EQ. -3 .OR. IND .EQ. -7) X1 = 0.0 C CALL URNG0 (IX, U, V) CALL GAMINV (B, X2, 0.0, U, V, IND) IF (IND .EQ. -3 .OR. IND .EQ. -7) X2 = 0.0 C C IT IS REQUIRED THAT A AND B NOT BE LESS C THAN 0.25 SO THAT X1 + X2 IS NONZERO. C X(I) = X1/(X1 + X2) C 10 CONTINUE RETURN C C ERROR RETURN C 100 IERR = 1 RETURN 110 IERR = 2 RETURN 120 IERR = 3 RETURN END SUBROUTINE DRBETA (N, A, B, IX, X, IERR) C----------------------------------------------------------------------- C C DOUBLE PRECISION C GENERATION OF BETA RANDOM VARIATES C C ------------ C C DRBETA GENERATES N DOUBLE PRECISION VARIATES FROM THE BETA C DISTRIBUTION WITH PARAMETERS A AND B WHERE A .GE. 0.25 AND C B .GE. 0.25. THE GENERATION SCHEME IS BASED ON THE FACT C THAT X1 / (X1 + X2) IS A VARIATE FROM THE BETA DISTRIBUTION C WHEN X1 AND X2 ARE INDEPENDENT VARIATES FROM THE STANDARD C GAMMA DISTRIBUTIONS WITH PARAMETERS A AND B RESPECTIVELY. C C FORM OF THE BETA PROBABILITY DENSITY FUNCTION USED... C C F(X) = X**(A - 1) * (1 - X)**(B - 1) / BETA(A,B) C C WHERE 0 .LE. X .LE. 1 AND C BETA(A,B) IS THE BETA FUNCTION. C C MEAN AND VARIANCE OF THE BETA DISTRIBUTION... C C MEAN = A / (A + B) C C VARIANCE = (A * B) / ((A + B)**2 * (A + B + 1)) C C INPUT... C C N - NUMBER OF VARIATES TO BE GENERATED C A - PARAMETER OF THE BETA DISTRIBUTION C B - PARAMETER OF THE BETA DISTRIBUTION C IX - INTEGER SEED USED TO INITIALIZE THE C SEQUENCE OF VARIATES C C OUTPUT... C C IX - SEED TO BE USED FOR OBTAINING MORE C VARIATES C X - ARRAY OF DIMENSION N CONTAINING THE C BETA VARIATES C IERR - INPUT ERROR FLAG C (0 - NO INPUT ERRORS C 1 - N .LE. 0 C 2 - A OR B IS LESS THAN 0.25 C 3 - SEED OUT OF RANGE ) C C----------------------------------------------------------------------- DOUBLE PRECISION A, B, X(N) DOUBLE PRECISION U, V, X1, X2 C-------------------- DATA MAX /2147483647/ C-------------------- IF (N .LE. 0) GO TO 100 IF (DMIN1(A,B) .LT. 0.25D0) GO TO 110 IF (IX .LE. 0 .OR. IX .GE. MAX) GO TO 120 IERR = 0 C DO 10 I = 1,N C C THE FOLLOWING CODE ASSUMES THAT THE UNIFORM C VARIATES ARE FAR ENOUGH FROM 0 AND 1 SO THAT C THE SETTING IND = -8 IN GAMINV IS AVOIDED. C CALL DURNG0 (IX, U, V) CALL DGINV (A, X1, U, V, IND) IF (IND .EQ. -3 .OR. IND .EQ. -7) X1 = 0.D0 C CALL DURNG0 (IX, U, V) CALL DGINV (B, X2, U, V, IND) IF (IND .EQ. -3 .OR. IND .EQ. -7) X2 = 0.D0 C C IT IS REQUIRED THAT A AND B NOT BE LESS C THAN 0.25 SO THAT X1 + X2 IS NONZERO. C X(I) = X1/(X1 + X2) C 10 CONTINUE RETURN C C ERROR RETURN C 100 IERR = 1 RETURN 110 IERR = 2 RETURN 120 IERR = 3 RETURN END SUBROUTINE FRAN (N, A, B, IX, X, IERR) C----------------------------------------------------------------------- C C GENERATION OF VARIATES FROM THE F-DISTRIBUTION C C -------------- C C FRAN GENERATES N VARIATES FROM THE F-DISTRIBUTION WITH C PARAMETERS A AND B (CALLED THE NUMERATOR AND DENOMINATOR C DEGREES OF FREEDOM) WHERE A .GE. 0.5 AND B .GE. 0.5. THE C GENERATION SCHEME IS BASED ON THE FACT THAT (B/A)*(X1/X2) C IS A VARIATE FROM THE F-DISTRIBUTION WHEN X1 AND X2 ARE C INDEPENDENT VARIATES FROM THE STANDARD GAMMA DISTRIBUTIONS C WITH PARAMETERS A/2 AND B/2 RESPECTIVELY. C C C INPUT... C C N - NUMBER OF VARIATES TO BE GENERATED C A - NUMERATOR DEGREES OF FREEDOM PARAMETER C B - DENOMINATOR DEGREES OF FREEDOM PARAMETER C IX - INTEGER SEED USED TO INITIALIZE THE C SEQUENCE OF VARIATES C C OUTPUT... C C IX - SEED TO BE USED FOR OBTAINING MORE C VARIATES C X - ARRAY OF DIMENSION N CONTAINING THE C F DISTRIBUTION VARIATES C IERR - INPUT ERROR FLAG C (0 - NO INPUT ERRORS C 1 - N .LE. 0 C 2 - A OR B IS LESS THAN 0.5 C 3 - B IS TOO SMALL FOR THE C FLOATING ARITHMETIC USED C 4 - SEED OUT OF RANGE ) C C----------------------------------------------------------------------- REAL X(N) C-------------------- DATA MAX /2147483647/ C-------------------- C C ****** XMAX IS A MACHINE DEPENDENT CONSTANT. XMAX IS THE C LARGEST NUMBER IN THE FLOATING ARITHMETIC USED. C XMAX = SPMPAR(3) C C-------------------- IF (N .LE. 0) GO TO 100 IF (AMIN1(A,B) .LT. 0.5) GO TO 110 IF (IX .LE. 0 .OR. IX .GE. MAX) GO TO 130 IERR = 0 C AHALF = 0.5*A BHALF = 0.5*B C = B/A BIG = 0.5*XMAX BOUND = AMAX1(C, 1.0) C DO 10 I = 1,N C C THE FOLLOWING CODE ASSUMES THAT THE UNIFORM C VARIATES ARE FAR ENOUGH FROM 0 AND 1 SO THAT C THE SETTING IND = -8 IN GAMINV IS AVOIDED. C CALL URNG0 (IX, U, V) CALL GAMINV (AHALF, X1, 0.0, U, V, IND) IF (IND .EQ. -3 .OR. IND .EQ. -7) X1 = 0.0 C CALL URNG0 (IX, U, V) CALL GAMINV (BHALF, X2, 0.0, U, V, IND) IF (IND .EQ. -3 .OR. IND .EQ. -7) GO TO 120 C C PROTECT AGAINST OVERFLOW IN COMPUTING THE C VARIATE C*(X1/X2). C T = X1 + X2 X1 = X1/T X2 = X2/T IF (X2*BIG .LE. BOUND) GO TO 120 X(I) = C * (X1/X2) 10 CONTINUE RETURN C C ERROR RETURN C 100 IERR = 1 RETURN 110 IERR = 2 RETURN 120 IERR = 3 RETURN 130 IERR = 4 RETURN END SUBROUTINE DFRAN (N, A, B, IX, X, IERR) C----------------------------------------------------------------------- C C DOUBLE PRECISION GENERATION OF C VARIATES FROM THE F-DISTRIBUTION C C -------------- C C DFRAN GENERATES N VARIATES FROM THE F-DISTRIBUTION WITH C PARAMETERS A AND B (CALLED THE NUMERATOR AND DENOMINATOR C DEGREES OF FREEDOM) WHERE A .GE. 0.5 AND B .GE. 0.5. THE C GENERATION SCHEME IS BASED ON THE FACT THAT (B/A)*(X1/X2) C IS A VARIATE FROM THE F-DISTRIBUTION WHEN X1 AND X2 ARE C INDEPENDENT VARIATES FROM THE STANDARD GAMMA DISTRIBUTIONS C WITH PARAMETERS A/2 AND B/2 RESPECTIVELY. C C C INPUT... C C N - NUMBER OF VARIATES TO BE GENERATED C A - NUMERATOR DEGREES OF FREEDOM PARAMETER C B - DENOMINATOR DEGREES OF FREEDOM PARAMETER C IX - INTEGER SEED USED TO INITIALIZE THE C SEQUENCE OF VARIATES C C OUTPUT... C C IX - SEED TO BE USED FOR OBTAINING MORE C VARIATES C X - ARRAY OF DIMENSION N CONTAINING THE C F DISTRIBUTION VARIATES C IERR - INPUT ERROR FLAG C (0 - NO INPUT ERRORS C 1 - N .LE. 0 C 2 - A OR B IS LESS THAN 0.5 C 3 - B IS TOO SMALL FOR THE C FLOATING ARITHMETIC USED C 4 - SEED OUT OF RANGE ) C C----------------------------------------------------------------------- DOUBLE PRECISION A, B, X(N) DOUBLE PRECISION AHALF, BHALF, BIG, BOUND, C, T, U, V, * XMAX, X1, X2 DOUBLE PRECISION DPMPAR C-------------------- DATA MAX /2147483647/ C-------------------- C C ****** XMAX IS A MACHINE DEPENDENT CONSTANT. XMAX IS THE C LARGEST NUMBER IN THE FLOATING ARITHMETIC USED. C XMAX = DPMPAR(3) C C-------------------- IF (N .LE. 0) GO TO 100 IF (DMIN1(A,B) .LT. 0.5D0) GO TO 110 IF (IX .LE. 0 .OR. IX .GE. MAX) GO TO 130 IERR = 0 C AHALF = 0.5D0*A BHALF = 0.5D0*B C = B/A BIG = 0.5D0*XMAX BOUND = DMAX1(C, 1.D0) C DO 10 I = 1,N C C THE FOLLOWING CODE ASSUMES THAT THE UNIFORM C VARIATES ARE FAR ENOUGH FROM 0 AND 1 SO THAT C THE SETTING IND = -8 IN GAMINV IS AVOIDED. C CALL DURNG0 (IX, U, V) CALL DGINV (AHALF, X1, U, V, IND) IF (IND .EQ. -3 .OR. IND .EQ. -7) X1 = 0.D0 C CALL DURNG0 (IX, U, V) CALL DGINV (BHALF, X2, U, V, IND) IF (IND .EQ. -3 .OR. IND .EQ. -7) GO TO 120 C C PROTECT AGAINST OVERFLOW IN COMPUTING THE C VARIATE C*(X1/X2). C T = X1 + X2 X1 = X1/T X2 = X2/T IF (X2*BIG .LE. BOUND) GO TO 120 X(I) = C * (X1/X2) 10 CONTINUE RETURN C C ERROR RETURN C 100 IERR = 1 RETURN 110 IERR = 2 RETURN 120 IERR = 3 RETURN 130 IERR = 4 RETURN END SUBROUTINE TRAN (N, A, IX, X, IERR) C----------------------------------------------------------------------- C C GENERATION OF VARIATES FROM THE T-DISTRIBUTION C C -------------- C C TRAN GENERATES N RANDOM VARIATES FROM A T-DISTRIBUTION C WITH PARAMETER A (CALLED THE DEGREES OF FREEDOM) WHERE C A .GE. 0.5. THE GENERATION SCHEME IS BASED ON THE FACT C THAT X/SQRT(Y/A) IS A VARIATE FROM THE T-DISTRIBUTION C WHEN X IS A STANDARD NORMAL VARIATE AND Y A CHI-SQUARE C VARIATE WITH A DEGREES OF FREEDOM. C C C INPUT... C C N - NUMBER OF VARIATES TO BE GENERATED C A - DEGREES OF FREEDOM PARAMETER C IX - INTEGER SEED USED TO INITIALIZE THE C SEQUENCE OF VARIATES C C OUTPUT... C C IX - SEED TO BE USED FOR OBTAINING MORE C VARIATES C X - ARRAY OF DIMENSION N CONTAINING THE C T-DISTRIBUTION VARIATES C IERR - INPUT ERROR FLAG C (0 - NO INPUT ERRORS C 1 - N .LE. 0 C 2 - A .LT. 0.5 C 3 - A IS TOO SMALL FOR THE C FLOATING ARITHMETIC USED C 4 - SEED OUT OF RANGE ) C C----------------------------------------------------------------------- REAL X(N) C-------------------- DATA MAX /2147483647/ C-------------------- IF (N .LE. 0) GO TO 100 IF (A .LT. 0.5) GO TO 110 IF (IX .LE. 0 .OR. IX .GE. MAX) GO TO 130 C IERR = 0 AHALF = 0.5*A C DO 10 I = 1,N C C GET A NORMAL VARIATE C CALL URNG1 (IX, U, V, D) CALL PNI (U, V, D, Z, IND) C C GET A GAMMA VARIATE C C THE FOLLOWING CODE ASSUMES THAT THE UNIFORM C VARIATES ARE FAR ENOUGH FROM 0 AND 1 SO THAT C THE SETTING IND = -8 IN GAMINV IS AVOIDED. C CALL URNG0 (IX, U, V) CALL GAMINV (AHALF, W, 0.0, U, V, IND) IF (IND .EQ. -3 .OR. IND .EQ. -7) GO TO 120 C S = SQRT(W/AHALF) X(I) = Z/S 10 CONTINUE RETURN C C ERROR RETURN C 100 IERR = 1 RETURN 110 IERR = 2 RETURN 120 IERR = 3 RETURN 130 IERR = 4 RETURN END SUBROUTINE DTRAN (N, A, IX, X, IERR) C----------------------------------------------------------------------- C C DOUBLE PRECISION GENERATION OF C VARIATES FROM THE T-DISTRIBUTION C C -------------- C C DTRAN GENERATES N RANDOM VARIATES FROM A T-DISTRIBUTION C WITH PARAMETER A (CALLED THE DEGREES OF FREEDOM) WHERE C A .GE. 0.5. THE GENERATION SCHEME IS BASED ON THE FACT C THAT X/SQRT(Y/A) IS A VARIATE FROM THE T-DISTRIBUTION C WHEN X IS A STANDARD NORMAL VARIATE AND Y A CHI-SQUARE C VARIATE WITH A DEGREES OF FREEDOM. C C C INPUT... C C N - NUMBER OF VARIATES TO BE GENERATED C A - DEGREES OF FREEDOM PARAMETER C IX - INTEGER SEED USED TO INITIALIZE THE C SEQUENCE OF VARIATES C C OUTPUT... C C IX - SEED TO BE USED FOR OBTAINING MORE C VARIATES C X - ARRAY OF DIMENSION N CONTAINING THE C T-DISTRIBUTION VARIATES C IERR - INPUT ERROR FLAG C (0 - NO INPUT ERRORS C 1 - N .LE. 0 C 2 - A .LT. 0.5 C 3 - A IS TOO SMALL FOR THE C FLOATING ARITHMETIC USED C 4 - SEED OUT OF RANGE ) C C----------------------------------------------------------------------- DOUBLE PRECISION A, X(N) DOUBLE PRECISION AHALF, D, S, U, V, W, Z C-------------------- DATA MAX /2147483647/ C-------------------- IF (N .LE. 0) GO TO 100 IF (A .LT. 0.5D0) GO TO 110 IF (IX .LE. 0 .OR. IX .GE. MAX) GO TO 130 C IERR = 0 AHALF = 0.5D0*A C DO 10 I = 1,N C C GET A NORMAL VARIATE C CALL DURNG1 (IX, U, V, D) CALL DPNI (U, V, D, Z, IND) C C GET A GAMMA VARIATE C C THE FOLLOWING CODE ASSUMES THAT THE UNIFORM C VARIATES ARE FAR ENOUGH FROM 0 AND 1 SO THAT C THE SETTING IND = -8 IN GAMINV IS AVOIDED. C CALL DURNG0 (IX, U, V) CALL DGINV (AHALF, W, U, V, IND) IF (IND .EQ. -3 .OR. IND .EQ. -7) GO TO 120 C S = DSQRT(W/AHALF) X(I) = Z/S 10 CONTINUE RETURN C C ERROR RETURN C 100 IERR = 1 RETURN 110 IERR = 2 RETURN 120 IERR = 3 RETURN 130 IERR = 4 RETURN END SUBROUTINE RMK1 (N, FMU, SIG, ALPHA, ISEED, X, IERROR) C C ***SUBROUTINE PURPOSE AND DESCRIPTION*** C C RMK1 GENERATES AN AUTOCORRELATED SEQUENCE X OF C LENGTH N WHERE X IS A FIRST-ORDER MARKOV PROCESS C WITH PARAMETER ALPHA (ABS(ALPHA) .LT. 1). THE SEQUENCE C X(J) (J = 2,...,N) IS GENERATED BY C C X(J) - FMU = ALPHA*(X(J-1) - FMU) + Z(J). C C Z(J) IS THE RANDOM ERROR TERM, ASSUMED TO BE NORMALLY C DISTRIBUTED WITH MEAN 0 AND STANDARD DEVIATION SIG C (SIG .GE. 0). THE GENERATION SCHEME ASSUMES THAT X IS C A NORMAL PROCESS WITH MEAN FMU AND VARIANCE C C SIG*SIG / (1 - ALPHA*ALPHA) . C C X IS A STATIONARY PROCESS PROVIDED THAT ABS(ALPHA) .LT. C 1. THE AUTOCORRELATION STRUCTURE OF THE SEQUENCE IS C CHARACTERIZED BY THE FACT THAT THE CORRELATION BETWEEN C TERMS BECOMES PROGRESSIVELY WEAKER WITH INCREASING LAG. C WE NOTE THAT A FIRST-ORDER MARKOV PROCESS IS SYNONOMOUS C WITH A FIRST-ORDER AUTOREGRESSIVE (AR) PROCESS. C C ***PARAMETER LIST*** C C INPUT... C C N - LENGTH OF THE SEQUENCE TO BE GENERATED. C IT IS ASSUMED THAT N .GE. 2. C FMU - MEAN OF THE NORMAL PROCESS C SIG - STANDARD DEVIATION OF THE NORMALLY C DISTRIBUTED ERROR TERM C ALPHA - VALUE OF THE MARKOV MODEL PARAMETER C ISEED - INTEGER SEED USED TO INITIALIZE THE C SEQUENCE OF NORMAL VARIATES GENERATED C BY SUBROUTINE RNOR C C OUTPUT... C C ISEED - SEED TO BE USED ON THE NEXT CALL TO THE C ROUTINE C X - OUTPUT ARRAY OF DIMENSION N CONTAINING C THE GENERATED FIRST-ORDER MARKOV SEQUENCE C IERROR - INPUT ERROR FLAG C ( 0 - NO INPUT ERRORS C 1 - N .LE. 1 C 2 - SIG .LT. 0 C 3 - ABS(ALPHA) .GE. 1 C 4 - SEED OUT OF RANGE ) C C ***REFERENCE*** C C FISHMAN, GEORGE S., CONCEPTS AND METHODS IN DISCRETE EVENT C DIGITAL SIMULATION, JOHN WILEY AND SONS, NEW YORK, 1973, C PP. 236 - 237. C REAL X(N) C C CHECK TO ENSURE THAT THE DESIRED SEQUENCE LENGTH IS WITHIN C ACCEPTABLE RANGE C IF (N .LE. 1) GO TO 100 C C CHECK TO ENSURE THAT THE STANDARD DEVIATION OF THE ERROR TERM C IS WITHIN ACCEPTABLE RANGE C IF (SIG .LE. 0.0) GO TO 110 C C CHECK TO ENSURE THAT THE FIRST-ORDER MARKOV MODEL C PARAMETER IS WITHIN THE RANGE REQUIRED TO GUARANTEE C PROCESS STATIONARITY C IF (ABS(ALPHA) .GE. 1.0) GO TO 120 C C GENERATION OF STANDARD NORMAL RANDOM VARIATES C CALL RNOR (ISEED,X,N,IERROR) IF (IERROR .NE. 0) GO TO 130 C C COMPUTES THE STANDARD DEVIATION OF THE INITIAL TERM OF THE C AUTOCORRELATED SEQUENCE C C = 0.5 + (0.5 - ALPHA) T = 0.5 + (0.5 + ALPHA) SIGI = SIG/SQRT(C*T) C C COMPUTES THE INITIAL TERM OF THE REQUIRED AUTOCORRELATED C SEQUENCE C X(1) = FMU + SIGI*X(1) C C GENERATES THE LAST N - 1 TERMS OF THE REQUIRED AUTOCORRELATED C SEQUENCE C C = FMU*C DO 10 I=2,N X(I) = ALPHA*X(I-1) + C + SIG*X(I) 10 CONTINUE RETURN C C ERROR RETURN C 100 IERROR = 1 RETURN 110 IERROR = 2 RETURN 120 IERROR = 3 RETURN 130 IERROR = 4 RETURN END SUBROUTINE DRMK1 (N, FMU, SIG, ALPHA, ISEED, X, IERROR) C C ***SUBROUTINE PURPOSE AND DESCRIPTION*** C C DRMK1 GENERATES AN AUTOCORRELATED SEQUENCE X OF C LENGTH N WHERE X IS A FIRST-ORDER MARKOV PROCESS C WITH PARAMETER ALPHA (ABS(ALPHA) .LT. 1). THE SEQUENCE C X(J) (J = 2,...,N) IS GENERATED BY C C X(J) - FMU = ALPHA*(X(J-1) - FMU) + Z(J). C C Z(J) IS THE RANDOM ERROR TERM, ASSUMED TO BE NORMALLY C DISTRIBUTED WITH MEAN 0 AND STANDARD DEVIATION SIG C (SIG .GE. 0). THE GENERATION SCHEME ASSUMES THAT X IS C A NORMAL PROCESS WITH MEAN FMU AND VARIANCE C C SIG*SIG / (1 - ALPHA*ALPHA) . C C X IS A STATIONARY PROCESS PROVIDED THAT ABS(ALPHA) .LT. C 1. THE AUTOCORRELATION STRUCTURE OF THE SEQUENCE IS C CHARACTERIZED BY THE FACT THAT THE CORRELATION BETWEEN C TERMS BECOMES PROGRESSIVELY WEAKER WITH INCREASING LAG. C WE NOTE THAT A FIRST-ORDER MARKOV PROCESS IS SYNONOMOUS C WITH A FIRST-ORDER AUTOREGRESSIVE (AR) PROCESS. C C ***PARAMETER LIST*** C C INPUT... C C N - LENGTH OF THE SEQUENCE TO BE GENERATED. C IT IS ASSUMED THAT N .GE. 2. C FMU - MEAN OF THE NORMAL PROCESS C SIG - STANDARD DEVIATION OF THE NORMALLY C DISTRIBUTED ERROR TERM C ALPHA - VALUE OF THE MARKOV MODEL PARAMETER C ISEED - INTEGER SEED USED TO INITIALIZE THE C SEQUENCE OF NORMAL VARIATES GENERATED C BY SUBROUTINE DRNOR C C OUTPUT... C C ISEED - SEED TO BE USED ON THE NEXT CALL TO THE C ROUTINE C X - OUTPUT ARRAY OF DIMENSION N CONTAINING C THE GENERATED FIRST-ORDER MARKOV SEQUENCE C IERROR - INPUT ERROR FLAG C ( 0 - NO INPUT ERRORS C 1 - N .LE. 1 C 2 - SIG .LT. 0 C 3 - ABS(ALPHA) .GE. 1 C 4 - SEED OUT OF RANGE ) C C ***REFERENCE*** C C FISHMAN, GEORGE S., CONCEPTS AND METHODS IN DISCRETE EVENT C DIGITAL SIMULATION, JOHN WILEY AND SONS, NEW YORK, 1973, C PP. 236 - 237. C DOUBLE PRECISION FMU, SIG, ALPHA, X(N) DOUBLE PRECISION C, SIGI, T C C CHECK TO ENSURE THAT THE DESIRED SEQUENCE LENGTH IS WITHIN C ACCEPTABLE RANGE C IF (N .LE. 1) GO TO 100 C C CHECK TO ENSURE THAT THE STANDARD DEVIATION OF THE ERROR TERM C IS WITHIN ACCEPTABLE RANGE C IF (SIG .LE. 0.D0) GO TO 110 C C CHECK TO ENSURE THAT THE FIRST-ORDER MARKOV MODEL C PARAMETER IS WITHIN THE RANGE REQUIRED TO GUARANTEE C PROCESS STATIONARITY C IF (DABS(ALPHA) .GE. 1.D0) GO TO 120 C C GENERATION OF STANDARD NORMAL RANDOM VARIATES C CALL DRNOR (ISEED,X,N,IERROR) IF (IERROR .NE. 0) GO TO 130 C C COMPUTES THE STANDARD DEVIATION OF THE INITIAL TERM OF THE C AUTOCORRELATED SEQUENCE C C = 0.5D0 + (0.5D0 - ALPHA) T = 0.5D0 + (0.5D0 + ALPHA) SIGI = SIG/DSQRT(C*T) C C COMPUTES THE INITIAL TERM OF THE REQUIRED AUTOCORRELATED C SEQUENCE C X(1) = FMU + SIGI*X(1) C C GENERATES THE LAST N - 1 TERMS OF THE REQUIRED AUTOCORRELATED C SEQUENCE C C = FMU*C DO 10 I=2,N X(I) = ALPHA*X(I-1) + C + SIG*X(I) 10 CONTINUE RETURN C C ERROR RETURN C 100 IERROR = 1 RETURN 110 IERROR = 2 RETURN 120 IERROR = 3 RETURN 130 IERROR = 4 RETURN END